From patchwork Thu Sep 5 08: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: 1981132 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=OD4OpJbQ; 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 4WzsX61tfPz1yg7 for ; Thu, 5 Sep 2024 18:11:47 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8472B3865491 for ; Thu, 5 Sep 2024 08:11:45 +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 30481384F4B9 for ; Thu, 5 Sep 2024 08:11:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 30481384F4B9 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 30481384F4B9 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=1725523874; cv=none; b=vCxLqe6kvIJZyFEkSimUabLcZCvCUSNs7aCpHG78n4nW0eeFsgup8lngPg4Fr7HKmY2GJ64b1oGeW4uFNE2J9z0tNR6r9tgmsEPkEmwLAFUTXPdPvD6Hj2/4c0YU6Bu1PaBvBMLeV4Ay3i/jznuGvG4Ff/s9AheaNUTXV7Jld8g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725523874; c=relaxed/simple; bh=ZOzoDAqgjq9jaMjWulgOzbWQPwWyKZYlK/y1LSlUWw0=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=jPWZULk0WJHbu/8uYcZjmnaKNtLH3PPjzwQ02r6VmS9DBfOK0zc3JEoG9VajcW28iQDGxtaJsUTSqQomZnOrQE+GSI0+mpa3rpz/cXWTXzUJR88xXluPRv+nrivqkoZCGkT/YGUQOt0HPrNd+29aKsR1O6rvg7vrtoSh9j6UeLY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-42bb9d719d4so3772085e9.3 for ; Thu, 05 Sep 2024 01:11:11 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1725523870; x=1726128670; 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=9RwqRF+G/cuWEaXqQ2pVMdfVRvCAimOAW5fb8nuXj4E=; b=OD4OpJbQsImix/IZ6EspKLjwQoAgABxINncqZABi+TtQIBnz63itxt2K/MC/U0PALG /9TOWT0X0rHVVYiCCbGInfr3SB8SKCWe2SU1buIqEtRSdUVp+GxpSwBZi4HCDEeU6JRb h5uuk/jJJD8EpK0DCnSDpTblJ0a5krr0SsrwIoXoWHMPSTLAHMtIMgLqughUSVN6DbIE d2WJ7JGAfAIeByQt+Aw/r/7xiUbuIENhQ69aoxNZd9wTqnpn1+rONznMbEBMpJ8XPZVZ arfxMuBpqqlTUDzlIL+7dGmqjd9mvJTl8FEUwF6LuwaAwt+U+KzsW7sw+W9DThYGLnmX 57UQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1725523870; x=1726128670; 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=9RwqRF+G/cuWEaXqQ2pVMdfVRvCAimOAW5fb8nuXj4E=; b=PFO4oq1mKbUQNksOiWGZeKJChniDsXhDpP9XkFCMLG+B69245qdOQviixmIpRG6FJ3 Fv/FYivEXHU+IpdezcHBR8JI5t5ZZ5UiTQhCXKFNnS0SWHda43/DI5mpiGGKTpSd9B/X e7p5Ui8a0HecG4ZtnpyeU6Ddr8yKWkN1E7m8ZbmcS6WAQGUWDgF+SWpnDjv7jUMXkhP4 f/vIPONDz0q29WYy0z4G01UWK7+T0Ytv+USXbX58aT5Fag+omV3vW447n0j4SatLkz+u i5LErtwkKFyOytnEGhMxei7FH01JMlXUolRfxN8EaM27exNWLDpkGKHLt2uuJRT+xR4H LYRA== X-Gm-Message-State: AOJu0YxGqxwslUfAKS8qqWS5XmKLUdpjcolhi0xXDrJSDDqPdWeO3+FF pj3mV6l4rQQdfM1gWca2KUSt33GvjzexUAZWHqjZxJyeip9BIpkRB9dpU+z9mcshO40lscloE9k = X-Google-Smtp-Source: AGHT+IEKz1wzndPhZv86S+t0JQAzg1egG0EkEhBizZWoeRKd8mIlIwHzi5zZlP7A7ER8LsamvbvAoQ== X-Received: by 2002:a05:600c:1f90:b0:421:7bed:5274 with SMTP id 5b1f17b1804b1-42c880efb02mr73348485e9.10.1725523869126; Thu, 05 Sep 2024 01:11:09 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-42baf7fa745sm242524555e9.31.2024.09.05.01.11.08 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Sep 2024 01:11:08 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Ronan Desplanques Subject: [COMMITTED 1/6] ada: Tweak assertions in Inline.Cannot_Inline Date: Thu, 5 Sep 2024 10:10:51 +0200 Message-ID: <20240905081056.2402112-1-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.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 purpose of this patch is to silence a GNATSAS report. gcc/ada/ * inline.adb (Cannot_Inline): Remove assertion. * inline.ads (Cannot_Inline): Add precondition. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/inline.adb | 2 -- gcc/ada/inline.ads | 5 ++++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 519e26ecec8..5f310abafda 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -2136,8 +2136,6 @@ package body Inline is end; end if; - pragma Assert (Msg (Msg'Last) = '?'); - -- Legacy front-end inlining model if not Back_End_Inlining then diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index bc90c0ce6d8..696f4227c7b 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -165,7 +165,10 @@ package Inline is N : Node_Id; Subp : Entity_Id; Is_Serious : Boolean := False; - Suppress_Info : Boolean := False); + Suppress_Info : Boolean := False) + with + Pre => Msg'First <= Msg'Last + and then Msg (Msg'Last) = '?'; -- This procedure is called if the node N, an instance of a call to -- subprogram Subp, cannot be inlined. Msg is the message to be issued, -- which ends with ? (it does not end with ?p?, this routine takes care of From patchwork Thu Sep 5 08:10:52 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: 1981134 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=UYajMOKI; 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 4WzsYS5Kd9z1ygP for ; Thu, 5 Sep 2024 18:13:00 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E2F74384F4B9 for ; Thu, 5 Sep 2024 08:12:58 +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 456723864835 for ; Thu, 5 Sep 2024 08:11:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 456723864835 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 456723864835 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=1725523874; cv=none; b=ZtJbD3LGtyoWton95pdyQ1IQ++NfImnYMEly4JaCdrHy68DoHz9y7XAqngZyP8jlnsc0g8jYkklnXqQaIxl3eBtYXqnun+ee62GGJ7tRnRuWvjTPWH+H3SBtL89HswGaCwEtrUAkFPE9nEf9TwISb9GnDorIuzkP7ywkAXusCa4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725523874; c=relaxed/simple; bh=FzxLkjJ/VYtFOldo+KF00E50Wz1QzzZZ11RCjXi2KqE=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=owK3xr8gjKhGvCi4z/0uIcX/0rDCHbZ9GiyJDk6W3ZyggR85NxwBBmOcvyNNSJebaT+/s8NrZjScpJT+NYT5ZrZhXK2YoPod0ZeQldiH2I9a6huZsTq20w1tV7+rshTi9VDe6qPEMvF9pUB6DuMGTkZcr4rRm/cQd5dJ/s7kAb8= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32f.google.com with SMTP id 5b1f17b1804b1-42c7a384b18so3616595e9.0 for ; Thu, 05 Sep 2024 01:11:11 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1725523870; x=1726128670; 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=POW6TsjDJkDKaXaEjo3pGkv3x8Uigc6rmcXSBcH8IFI=; b=UYajMOKIfE9P7iKel/80jygz9gCcnzvHx2FDhOeZYL/cP+sSJgnLdIIyF1YlmRgttG j/6lg6FiXSSgal2JzdFF2tl/L+LOwPPR1KHeL1cQu8HaP93xZe5wUs5JYOQrjtOx4qFG AmtIcEk0CJQGvxjjsgG4SLxrAIuqtC3s6wubz+QMh/L2FnwYxYwVEFq5CoMi38NceiV2 LnAnem3Hj5ppRJeAMi8pYaEQu/6jougGV4Uhcn22uRIhCL11akqCqJQIA9SHKTlg9UkS 91mdxaAD/rioxZIp5gfrLXiXjGXenmTPosTfpDqnmWAt2D5uHKzToaimKezNvl7OZ8JD dm/w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1725523870; x=1726128670; 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=POW6TsjDJkDKaXaEjo3pGkv3x8Uigc6rmcXSBcH8IFI=; b=G2CSB4yfuErZZR81FiTBHLnSr5+Iy7/qg5qAOp5S4FyU3yvUIMquYl77FHQNDbj3hK wQ73nzSgCNmWeV8ov4NHkCKBLcZnv4lWih/lR2axwOD5wo+QzJt0Ct9z9EJsETXciz1a 2k/W8JXTG2bAwFrZSVKn/elrM3NZ+ga1CAACe1eyZxu+tXzNrbbd0IhIwOwUTduKvNwW XO7uTYySZGoeTKH3DjcVluuBX2cDgh6iU+pj6hxwGA8V/B95eiyOj3MZXzXZCaVog0t+ v8BJL9pBo/xFIoDico3CBIYpdf1Q0qJPb273E0pqZcDOMh2e05a4Q6JE9naDOdWe6ixx PDTg== X-Gm-Message-State: AOJu0Yyf78FBNOLX+Qs/3899GJ5v26Q1RCHqFRKXddKJGWCuYJO2uLPU U/Tuu6pv5Ix//uVuf7gvWoQ6+vmrQhY2z11qw9uGzli7E+KWmc6L8L7YGpjir2FLqbnuo02j5DY = X-Google-Smtp-Source: AGHT+IHKexK6JBlQKvXSDdkTpSwySahx7n5jGLChJ2vIrmv2/4uiFemE26grrjmsnAwnGpkOhqWbdA== X-Received: by 2002:a05:600c:4f95:b0:426:6ed2:6130 with SMTP id 5b1f17b1804b1-42bdc633522mr105720565e9.14.1725523869809; Thu, 05 Sep 2024 01:11:09 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-42baf7fa745sm242524555e9.31.2024.09.05.01.11.09 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Sep 2024 01:11:09 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Jose Ruiz Subject: [COMMITTED 2/6] ada: Binder respects Ada version for checksum of runtime files Date: Thu, 5 Sep 2024 10:10:52 +0200 Message-ID: <20240905081056.2402112-2-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240905081056.2402112-1-poulhies@adacore.com> References: <20240905081056.2402112-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.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: Jose Ruiz The parsing to compute the checksums of runtime files (within the binder) was done using the default Ada version (Ada 2012 currently), while the creation of the checksum, when the runtime files are compiled, is performed in a more recent Ada version (Ada 2022 currently). This change forces the checksum computation for runtime files to be done with the same Ada version as when they were created. gcc/ada/ * ali-util.adb (Get_File_Checksum): Force the parsing for the checksum computation of runtime files to be done in the corresponding recent Ada version. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/ali-util.adb | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index 61dddb94e85..4bcb06e6a1f 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -29,6 +29,7 @@ with Opt; use Opt; with Output; use Output; with Osint; use Osint; with Scans; use Scans; +with Fname; use Fname; with Scng; with Sinput.C; with Stringt; @@ -87,8 +88,10 @@ package body ALI.Util is ----------------------- function Get_File_Checksum (Fname : File_Name_Type) return Word is - Full_Name : File_Name_Type; - Source_Index : Source_File_Index; + Full_Name : File_Name_Type; + Source_Index : Source_File_Index; + Ada_Version_Current : Ada_Version_Type; + Internal_Unit : constant Boolean := Is_Internal_File_Name (Fname); begin Full_Name := Find_File (Fname, Osint.Source); @@ -109,6 +112,15 @@ package body ALI.Util is Scanner.Initialize_Scanner (Source_Index); + -- The runtime files are precompiled with an implicitly defined Ada + -- version that we set here to improve the parsing required to compute + -- the checksum. + + if Internal_Unit then + Ada_Version_Current := Ada_Version; + Ada_Version := Ada_Version_Runtime; + end if; + -- Scan the complete file to compute its checksum loop @@ -116,6 +128,12 @@ package body ALI.Util is exit when Token = Tok_EOF; end loop; + -- Restore the Ada version if we changed it + + if Internal_Unit then + Ada_Version := Ada_Version_Current; + end if; + return Scans.Checksum; end Get_File_Checksum; From patchwork Thu Sep 5 08: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: 1981137 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=X6u8E6Pn; 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 4Wzsdw3fQVz1yXY for ; Thu, 5 Sep 2024 18:16:52 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id CFD2E3860C34 for ; Thu, 5 Sep 2024 08:16:49 +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 2D4F3386481F for ; Thu, 5 Sep 2024 08:11:14 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2D4F3386481F 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 2D4F3386481F 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=1725523881; cv=none; b=QsH71aXTomh9FMaCliWwujDTRRiDyCW9zNMQlp4/GtEj309Jmhr4FOMGzXP2KVNdvWC9Wzd7p38GttRiB67uL0vt8G7Iar+Ng6h3+5ChqC0W4Sziam4ED102ITRVuR94mAvTIZ2Lt4TZiqGSuw7ImHcEnt72Z0nmDjMnoDTYV4U= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725523881; c=relaxed/simple; bh=1tYmribPjLPc/27EUZQRe7ncBCU9XD941xBFquy49bw=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=ZV+JHcemE84CCtMskiMcUHHHCTOlX20qOzP9RJuD0lhcAemYSDifhBzWjhN0Lnw3DiF6kT6+ejDeqxNBelaXbfdIrbaXZpXqYN9A/t8/m8wkz4XDxDmELVc+KMBVJ7HpVdWtl6sOGgd+JJzShaUXaEQqVVGIY+8igsxLBg03IRk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32b.google.com with SMTP id 5b1f17b1804b1-42bbf138477so3781165e9.2 for ; Thu, 05 Sep 2024 01:11:14 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1725523873; x=1726128673; 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=ztccPraGw2WBxKsUy+iCdNKWW+5rQPCdrbC5NKrCWm4=; b=X6u8E6PnYESgOU4sQdHwVLxQ8hWgyQEPRV4INF45zNARrdzkCM1L4iiph2lIcmuzZv NfmZxMPWI7JBlpQmZua1syBNLcmTHwd+f017CWibJDvTZuBSiMAUSSVw3NPzhfRGsGOt bHFOs9vTVjkCQh4WSYN+yxHB0tR1iL7EAfgzZ134fIH2lED3XLVYg52GkwvfJiVBCDZD +wvuDw1ewzFw48XH3lsOC5Dab8qy9RNfIreoGvf2XwXQrU+O0cuwEhfDP+/TEOqKDmWR lihBUFh8A8+X3NbpaiWkQaLitWlVefbJqPvpeBrz4jjZ3WTemNRMB0awx9GP+tv/KHOA Bv1g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1725523873; x=1726128673; 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=ztccPraGw2WBxKsUy+iCdNKWW+5rQPCdrbC5NKrCWm4=; b=tDkk28/qSS58WRsjxhv6nvc/Ed4rzTGuvhK6amXzSqMn8FkJb9LBB5NlIwfDSScEpT JA2u/qBFa+pJqzTulDfttTFfJJWdVR2tHIJqMswbBk57Eypf+7sLxBSW8he1LxPzR//B w/lHKrEdzvPAFDJNzKPZxx/Cm7Yi8zAS6RzBppUGnIlBvEieF3/C4McPHYMO2cFqazfk CSuOYEb6L/MDsWY3rzvJfWn717ZcwyVoTs5JijYz1Y3BSxTpyDTjxWigmY+xVP6NLi74 +9Iw1I3jpyyMTYZDMzVuyMiNOuWLcYK6DfmrGT1LLtRdIkQX/ucrZEexMSnat+g2sPzF LyWw== X-Gm-Message-State: AOJu0YxzyJg3gKHEBwDV1mcCuIc4BB0HJxErqkUsip9Y0NXlwC2k0JQk MLp5XspFpuL/x9AyLu08lh3VU1iCaIE+TscWDQowVcHiyzLLXj3rn8tivu9hvMAYmNrqwhordzI = X-Google-Smtp-Source: AGHT+IH4nSpYnbMlbq3jRMpXueS8i7MJ4LW7GG8FLw244AnOo+pk7dF+9Dz9uAjj/kCiit+M/cJxWg== X-Received: by 2002:a05:600c:2210:b0:426:5e8e:410a with SMTP id 5b1f17b1804b1-42c9946fb92mr21143845e9.24.1725523871364; Thu, 05 Sep 2024 01:11:11 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-42baf7fa745sm242524555e9.31.2024.09.05.01.11.10 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Sep 2024 01:11:10 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Viljar Indus Subject: [COMMITTED 3/6] ada: Integrate new diagnostics in the frontend Date: Thu, 5 Sep 2024 10:10:53 +0200 Message-ID: <20240905081056.2402112-3-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240905081056.2402112-1-poulhies@adacore.com> References: <20240905081056.2402112-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_SHORT, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE, WEIRD_QUOTING autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Viljar Indus Integrate diagnostic messages using the new implementation to the codebase. New diagnostic implementation uses GNAT.Lists as a building block. Tampering checks that were initially implemented for those lists are not critical for this implementation and they lead to overly complex code. Add a generic parameter Tampering_Checks to control whether the tempering checks should be applied for the lists. Make tampering checks conditional for GNAT.Lists gcc/ada/ * par-endh.adb: add call to new diagnostic for end loop errors. * sem_ch13.adb: add call to new diagnostic for default iterator error and record representation being too late. * sem_ch4.adb: Add new diagnostic for wrong operands. * sem_ch9.adb: Add new diagnostic for a Lock_Free warning. * libgnat/g-lists.adb (Ensure_Unlocked): Make checks for tampering conditional. * libgnat/g-lists.ads: Add parameter Tampering_Checks to control whether tampering checks should be executed. * backend_utils.adb: Add new gcc switches '-fdiagnostics-format=sarif-file' and '-fdiagnostics-format=sarif-stderr'. * debug.adb: document -gnatd_D switch. * diagnostics-brief_emitter.adb: New package for displaying diagnostic messages in a compact manner. * diagnostics-brief_emitter.ads: Same as above. * diagnostics-constructors.adb: New pacakge for providing simpler constructor methods for new diagnostic objects. * diagnostics-constructors.ads: Same as above. * diagnostics-converter.adb: New package for converting old Error_Msg_Object-s to Diagnostic_Types. * diagnostics-converter.ads: Same as above. * diagnostics-json_utils.adb: Package for utility methods related to emitting JSON. * diagnostics-json_utils.ads: Same as above. * diagnostics-pretty_emitter.adb: New package for displaying diagnostic messages in a more elaborate manner. * diagnostics-pretty_emitter.ads: Same as above. * diagnostics-repository.adb: New package for collecting all created error messages. * diagnostics-repository.ads: Same as above. * diagnostics-sarif_emitter.adb: New pacakge for converting all of the diagnostics into a report in the SARIF format. * diagnostics-sarif_emitter.ads: Same as above. * diagnostics-switch_repository.adb: New package containing the definitions for all of the warninging switches. * diagnostics-switch_repository.ads: Same as above. * diagnostics-utils.adb: Contains various utility methods for the diagnostic pacakges. * diagnostics-utils.ads: Same as above. * diagnostics.adb: Contains the definitions and common functions for all the new diagnostics objects. * diagnostics.ads: Same as above. * errout.adb: Relocate the old implementations for brief and pretty printing the diagnostic messages and the entrypoint to the new implementation if a debug switch is used. * errout.ads: Improve documentation. Make Set_Msg_Text publicly available. * opt.ads: Add the flag SARIF_File which controls whether the diagnostic messages should be printed to a file in the SARIF format. Add the flag SARIF_Output to control whether the diagnostic messages should be printed to std-err in the SARIF format. * gcc-interface/Make-lang.in: Add new pacakages to the object list. * gcc-interface/Makefile.in: Add new pacakages to the object list. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/backend_utils.adb | 15 + gcc/ada/debug.adb | 4 +- gcc/ada/diagnostics-brief_emitter.adb | 137 +++ gcc/ada/diagnostics-brief_emitter.ads | 28 + gcc/ada/diagnostics-constructors.adb | 475 ++++++++ gcc/ada/diagnostics-constructors.ads | 133 +++ gcc/ada/diagnostics-converter.adb | 281 +++++ gcc/ada/diagnostics-converter.ads | 31 + gcc/ada/diagnostics-json_utils.adb | 104 ++ gcc/ada/diagnostics-json_utils.ads | 67 ++ gcc/ada/diagnostics-pretty_emitter.adb | 1277 +++++++++++++++++++++ gcc/ada/diagnostics-pretty_emitter.ads | 28 + gcc/ada/diagnostics-repository.adb | 122 ++ gcc/ada/diagnostics-repository.ads | 108 ++ gcc/ada/diagnostics-sarif_emitter.adb | 1090 ++++++++++++++++++ gcc/ada/diagnostics-sarif_emitter.ads | 29 + gcc/ada/diagnostics-switch_repository.adb | 688 +++++++++++ gcc/ada/diagnostics-switch_repository.ads | 39 + gcc/ada/diagnostics-utils.adb | 358 ++++++ gcc/ada/diagnostics-utils.ads | 91 ++ gcc/ada/diagnostics.adb | 542 +++++++++ gcc/ada/diagnostics.ads | 481 ++++++++ gcc/ada/errout.adb | 214 ++-- gcc/ada/errout.ads | 25 +- gcc/ada/gcc-interface/Make-lang.in | 20 + gcc/ada/gcc-interface/Makefile.in | 10 + gcc/ada/libgnat/g-lists.adb | 2 +- gcc/ada/libgnat/g-lists.ads | 2 + gcc/ada/opt.ads | 13 + gcc/ada/par-endh.adb | 31 +- gcc/ada/sem_ch13.adb | 53 +- gcc/ada/sem_ch4.adb | 101 +- gcc/ada/sem_ch9.adb | 19 +- 33 files changed, 6460 insertions(+), 158 deletions(-) create mode 100644 gcc/ada/diagnostics-brief_emitter.adb create mode 100644 gcc/ada/diagnostics-brief_emitter.ads create mode 100644 gcc/ada/diagnostics-constructors.adb create mode 100644 gcc/ada/diagnostics-constructors.ads create mode 100644 gcc/ada/diagnostics-converter.adb create mode 100644 gcc/ada/diagnostics-converter.ads create mode 100644 gcc/ada/diagnostics-json_utils.adb create mode 100644 gcc/ada/diagnostics-json_utils.ads create mode 100644 gcc/ada/diagnostics-pretty_emitter.adb create mode 100644 gcc/ada/diagnostics-pretty_emitter.ads create mode 100644 gcc/ada/diagnostics-repository.adb create mode 100644 gcc/ada/diagnostics-repository.ads create mode 100644 gcc/ada/diagnostics-sarif_emitter.adb create mode 100644 gcc/ada/diagnostics-sarif_emitter.ads create mode 100644 gcc/ada/diagnostics-switch_repository.adb create mode 100644 gcc/ada/diagnostics-switch_repository.ads create mode 100644 gcc/ada/diagnostics-utils.adb create mode 100644 gcc/ada/diagnostics-utils.ads create mode 100644 gcc/ada/diagnostics.adb create mode 100644 gcc/ada/diagnostics.ads diff --git a/gcc/ada/backend_utils.adb b/gcc/ada/backend_utils.adb index 3591cd19bbf..f734a06c3ce 100644 --- a/gcc/ada/backend_utils.adb +++ b/gcc/ada/backend_utils.adb @@ -65,6 +65,21 @@ package body Backend_Utils is elsif Switch_Chars (First .. Last) = "fdiagnostics-format=json" then Opt.JSON_Output := True; + -- Back end switch -fdiagnostics-format=sarif-file tells the frontend + -- to output its error and warning messages in the sarif format. The + -- messages from gnat are written to a file .gnat.sarif. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=sarif-file" + then + Opt.SARIF_File := True; + + -- Back end switch -fdiagnostics-format=sarif-stderr tells the frontend + -- to output its error and warning messages in the sarif format. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=sarif-stderr" + then + Opt.SARIF_Output := True; + -- Back-end switch -fno-inline also sets the front end flags to entirely -- inhibit all inlining. So we store it and set the appropriate -- flags. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index fcd04dfb93b..2c0bff09e9d 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -168,8 +168,8 @@ package body Debug is -- d_A Stop generation of ALI file -- d_B Warn on build-in-place function calls -- d_C - -- d_D - -- d_E + -- d_D Use improved diagnostics + -- d_E Print diagnostics and switch repository -- d_F Encode full invocation paths in ALI files -- d_G -- d_H diff --git a/gcc/ada/diagnostics-brief_emitter.adb b/gcc/ada/diagnostics-brief_emitter.adb new file mode 100644 index 00000000000..9ba137e07d8 --- /dev/null +++ b/gcc/ada/diagnostics-brief_emitter.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . B R I E F _ E M I T T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Utils; use Diagnostics.Utils; +with Erroutc; use Erroutc; +with Opt; use Opt; +with Output; use Output; + +package body Diagnostics.Brief_Emitter is + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type); + + -------------------------- + -- Print_Sub_Diagnostic -- + -------------------------- + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + is + -- In GNAT sub messages were grouped by the main messages by also having + -- the same location. In the brief printer we use the primary location + -- of the main diagnostic for all of the subdiagnostics. + Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + + Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; + + Text : String_Ptr; + + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last + else Error_Msg_Line_Length); + + Switch_Str : constant String := Get_Doc_Switch (Diag); + begin + Text := new String'(To_String (Sptr) & ": " + & Kind_To_String (Sub_Diag, Diag) & ": " + & Sub_Diag.Message.all); + + if Switch_Str /= "" then + Text := new String'(Text.all & " " & Switch_Str); + end if; + + if Diag.Warn_Err then + Text := new String'(Text.all & " [warning-as-error]"); + end if; + + Output_Text_Within (Text, Line_Length); + Write_Eol; + end Print_Sub_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diag : Diagnostic_Type) is + use Sub_Diagnostic_Lists; + + Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + + Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; + + Text : String_Ptr; + + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last + else Error_Msg_Line_Length); + + Switch_Str : constant String := Get_Doc_Switch (Diag); + begin + Write_Str (To_String (Sptr) & ": "); + + -- Ignore the message prefix on Style messages. They will use + -- the (style) prefix within the message. + -- + -- Also disable the "error:" prefix if Unique_Error_Tag is unset. + + if (Diag.Kind = Style and then not Diag.Warn_Err) + or else (Diag.Kind = Error and then not Unique_Error_Tag) + then + Text := new String'(""); + else + Text := new String'(Kind_To_String (Diag) & ": "); + end if; + + Text := new String'(Text.all & Diag.Message.all); + + if Switch_Str /= "" then + Text := new String'(Text.all & " " & Switch_Str); + end if; + + if Diag.Warn_Err then + Text := new String'(Text.all & " [warning-as-error]"); + end if; + + Output_Text_Within (Text, Line_Length); + Write_Eol; + + if Present (Diag.Sub_Diagnostics) then + declare + + Sub_Diag : Sub_Diagnostic_Type; + + It : Iterator := Iterate (Diag.Sub_Diagnostics); + begin + while Has_Next (It) loop + Next (It, Sub_Diag); + + Print_Sub_Diagnostic (Sub_Diag, Diag); + end loop; + end; + end if; + + end Print_Diagnostic; +end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-brief_emitter.ads b/gcc/ada/diagnostics-brief_emitter.ads new file mode 100644 index 00000000000..1759b210a09 --- /dev/null +++ b/gcc/ada/diagnostics-brief_emitter.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . B R I E F _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Brief_Emitter is + procedure Print_Diagnostic (Diag : Diagnostic_Type); +end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-constructors.adb b/gcc/ada/diagnostics-constructors.adb new file mode 100644 index 00000000000..8a9e10a7cbe --- /dev/null +++ b/gcc/ada/diagnostics-constructors.adb @@ -0,0 +1,475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N S T R U C T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Sinfo.Nodes; use Sinfo.Nodes; +with Diagnostics.Utils; use Diagnostics.Utils; + +package body Diagnostics.Constructors is + + ----------------------------------------------- + -- Make_Default_Iterator_Not_Primitive_Error -- + ----------------------------------------------- + + function Make_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "improper function for default iterator", + Location => Primary_Labeled_Span (Expr), + Id => GNAT0001, + Kind => Diagnostics.Error, + Sub_Diags => + (1 => + Continuation + (Msg => + "default iterator defined " & + Sloc_To_String (Subp, Sloc (Expr)) & + " must be a primitive function", + Locations => + (1 => Primary_Labeled_Span (Subp))))); + end Make_Default_Iterator_Not_Primitive_Error; + + ------------------------------------------------- + -- Record_Default_Iterator_Not_Primitive_Error -- + ------------------------------------------------- + + procedure Record_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) + is + begin + Record_Diagnostic + (Make_Default_Iterator_Not_Primitive_Error (Expr, Subp)); + end Record_Default_Iterator_Not_Primitive_Error; + + --------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_Error -- + --------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0002, + Kind => Diagnostics.Error, + Spans => + (1 => + (Secondary_Labeled_Span + (N => L, + Label => To_Type_Name (L_Type))), + 2 => + Secondary_Labeled_Span + (N => R, + Label => To_Type_Name (R_Type)))); + end Make_Invalid_Operand_Types_For_Operator_Error; + + ----------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_Error -- + ----------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Int_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0003, + Kind => Diagnostics.Error, + Spans => + (1 => + (Secondary_Labeled_Span + (N => L, + Label => + "left operand has type " & + To_Name (L_Type))), + 2 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand has type " & + To_Name (R_Type))), + Sub_Diags => + (1 => Suggestion (Msg => "Convert left operand to ""Integer""") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_L_Int_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_L_Int_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_L_Int_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_R_Int_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0004, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => L, + Label => + "left operand has type " & + To_Name (L_Type)), + 2 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand has type " & + To_Name (R_Type))), + Sub_Diags => + (1 => Suggestion (Msg => "Convert right operand to ""Integer""") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_R_Int_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_R_Int_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_R_Int_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0005, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => L, + Label => + "left operand is access type ") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_L_Acc_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op, L)); + end Record_Invalid_Operand_Types_For_Operator_L_Acc_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0006, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand is access type ") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_R_Acc_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_R_Acc_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op, R)); + end Record_Invalid_Operand_Types_For_Operator_R_Acc_Error; + + ----------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_General_Error -- + ----------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0007, + Kind => Diagnostics.Error + ); + end Make_Invalid_Operand_Types_For_Operator_General_Error; + + ------------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_General_Error -- + ------------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_General_Error (Op)); + end Record_Invalid_Operand_Types_For_Operator_General_Error; + + -------------------------------------------------- + -- Make_Pragma_No_Effect_With_Lock_Free_Warning -- + -------------------------------------------------- + + function Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; Lock_Free_Range : Node_Id) + return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + "pragma " & '"' & Get_Name_String (Pragma_Name) & '"' & + " for " & To_Name (Lock_Free_Node) & + " has no effect when Lock_Free given", + Location => Primary_Labeled_Span (Pragma_Node, "No effect"), + Id => GNAT0008, + Kind => Diagnostics.Warning, + Spans => + (1 => + Labeled_Span + (Span => To_Full_Span (Lock_Free_Range), + Label => "Lock_Free in effect here", + Is_Primary => False, + Is_Region => True))); + end Make_Pragma_No_Effect_With_Lock_Free_Warning; + + -------------------------------------------- + -- Record_Pragma_No_Effect_With_Lock_Free -- + -------------------------------------------- + + procedure Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id) + is + begin + Record_Diagnostic + (Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node, Pragma_Name, Lock_Free_Node, Lock_Free_Range)); + end Record_Pragma_No_Effect_With_Lock_Free_Warning; + + ---------------------------------- + -- Make_End_Loop_Expected_Error -- + ---------------------------------- + + function Make_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + """end loop;"" expected for ""loop"" " & + Sloc_To_String (Start_Loc, End_Loc.Ptr), + Location => Primary_Labeled_Span (End_Loc), + Id => GNAT0009, + Kind => Diagnostics.Error, + Spans => (1 => Secondary_Labeled_Span (To_Span (Start_Loc))), + Fixes => + (1 => + Fix + (Description => "Replace with 'end loop;'", + Edits => + (1 => Edit (Text => "end loop;", Span => End_Loc)), + Applicability => Legal))); + end Make_End_Loop_Expected_Error; + + ------------------------------------ + -- Record_End_Loop_Expected_Error -- + ------------------------------------ + + procedure Record_End_Loop_Expected_Error + (End_Loc : Source_Span; Start_Loc : Source_Ptr) + is + begin + Record_Diagnostic (Make_End_Loop_Expected_Error (End_Loc, Start_Loc)); + end Record_End_Loop_Expected_Error; + + ---------------------------------------- + -- Make_Representation_Too_Late_Error -- + ---------------------------------------- + + function Make_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + "record representation cannot be specified" & + " after the type is frozen", + Location => + Primary_Labeled_Span + (N => Rep, + Label => "record representation clause specified here"), + Id => GNAT0010, + Kind => Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => Freeze, + Label => + "Type " & To_Name (Def) & " is frozen here"), + 2 => + Secondary_Labeled_Span + (N => Def, + Label => + "Type " & To_Name (Def) & " is declared here")), + Sub_Diags => + (1 => + Suggestion + (Msg => + "move the record representation clause" & + " before the freeze point " & + Sloc_To_String (Sloc (Freeze), Sloc (Rep))))); + end Make_Representation_Too_Late_Error; + + ------------------------------------------ + -- Record_Representation_Too_Late_Error -- + ------------------------------------------ + + procedure Record_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + is + begin + Record_Diagnostic + (Make_Representation_Too_Late_Error (Rep, Freeze, Def)); + end Record_Representation_Too_Late_Error; + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-constructors.ads b/gcc/ada/diagnostics-constructors.ads new file mode 100644 index 00000000000..96782b3475f --- /dev/null +++ b/gcc/ada/diagnostics-constructors.ads @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N S T R U C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Namet; use Namet; + +package Diagnostics.Constructors is + + function Make_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) return Diagnostic_Type; + + procedure Record_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id); + + function Make_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id); + + function Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id) + return Diagnostic_Type; + + procedure Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id); + + function Make_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr) return Diagnostic_Type; + + procedure Record_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr); + + function Make_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + return Diagnostic_Type; + + procedure Record_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id); + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb new file mode 100644 index 00000000000..45bb19c0a84 --- /dev/null +++ b/gcc/ada/diagnostics-converter.adb @@ -0,0 +1,281 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N V E R T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Erroutc; use Erroutc; +with Debug; use Debug; +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.SARIF_Emitter; use Diagnostics.SARIF_Emitter; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +use Diagnostics.Diagnostics_Lists; +with System.OS_Lib; use System.OS_Lib; + +package body Diagnostics.Converter is + + function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type; + + function Convert_Sub_Diagnostic + (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type; + + function Get_Warning_Kind (E_Msg : Error_Msg_Object) return Diagnostic_Kind + is (if E_Msg.Info then Info_Warning + elsif E_Msg.Warn_Chr = "* " then Restriction_Warning + elsif E_Msg.Warn_Chr = "? " then Default_Warning + elsif E_Msg.Warn_Chr = " " then Tagless_Warning + else Warning); + -- NOTE: Some messages have both info and warning set to true. The old + -- printer added the warning switch label but treated the message as + -- an info message. + + ----------------------------------- + -- Convert_Errors_To_Diagnostics -- + ----------------------------------- + + procedure Convert_Errors_To_Diagnostics + is + E : Error_Msg_Id; + begin + E := First_Error_Msg; + while E /= No_Error_Msg loop + + if not Errors.Table (E).Deleted + and then not Errors.Table (E).Msg_Cont + then + + -- We do not need to update the count of converted error messages + -- since they are accounted for in their creation. + + Record_Diagnostic (Convert (E), Update_Count => False); + end if; + + E := Errors.Table (E).Next; + end loop; + + end Convert_Errors_To_Diagnostics; + + ---------------------------- + -- Convert_Sub_Diagnostic -- + ---------------------------- + + function Convert_Sub_Diagnostic + (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type + is + E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); + D : Sub_Diagnostic_Type; + begin + D.Message := E_Msg.Text; + + -- All converted sub-diagnostics are continuations. When emitted they + -- shall be printed with the same kind token as the main diagnostic. + D.Kind := Continuation; + + declare + L : Labeled_Span_Type; + begin + if E_Msg.Insertion_Sloc /= No_Location then + L.Span := To_Span (E_Msg.Insertion_Sloc); + else + L.Span := E_Msg.Sptr; + end if; + + L.Is_Primary := True; + Add_Location (D, L); + end; + + if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Optr; + L.Is_Primary := False; + Add_Location (D, L); + end; + end if; + + return D; + end Convert_Sub_Diagnostic; + + ------------- + -- Convert -- + ------------- + + function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type is + + E_Next_Id : Error_Msg_Id; + + E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); + D : Diagnostic_Type; + begin + D.Message := E_Msg.Text; + + if E_Msg.Warn then + D.Kind := Get_Warning_Kind (E_Msg); + D.Switch := Get_Switch_Id (E_Msg); + elsif E_Msg.Style then + D.Kind := Style; + D.Switch := Get_Switch_Id (E_Msg); + elsif E_Msg.Info then + D.Kind := Info; + D.Switch := Get_Switch_Id (E_Msg); + else + D.Kind := Error; + end if; + + D.Warn_Err := E_Msg.Warn_Err; + + D.Serious := E_Msg.Serious; + + -- Convert the primary location + + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Sptr; + L.Is_Primary := True; + Add_Location (D, L); + end; + + -- Convert the secondary location if it is different from the primary + + if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Optr; + L.Is_Primary := False; + Add_Location (D, L); + end; + end if; + + E_Next_Id := Errors.Table (E_Id).Next; + while E_Next_Id /= No_Error_Msg + and then Errors.Table (E_Next_Id).Msg_Cont + loop + Add_Sub_Diagnostic (D, Convert_Sub_Diagnostic (E_Next_Id)); + E_Next_Id := Errors.Table (E_Next_Id).Next; + end loop; + + return D; + end Convert; + + ---------------------- + -- Emit_Diagnostics -- + ---------------------- + + procedure Emit_Diagnostics is + D : Diagnostic_Type; + + It : Iterator := Iterate (All_Diagnostics); + + Sarif_File_Name : constant String := + Get_First_Main_File_Name & ".gnat.sarif"; + + Switches_File_Name : constant String := "gnat_switches.json"; + + Diagnostics_File_Name : constant String := "gnat_diagnostics.json"; + + Dummy : Boolean; + begin + if Opt.SARIF_Output then + Set_Standard_Error; + + Print_SARIF_Report (All_Diagnostics); + + Set_Standard_Output; + elsif Opt.SARIF_File then + Delete_File (Sarif_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Sarif_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_SARIF_Report (All_Diagnostics); + + Set_Standard_Output; + + Close (Output_FD); + end; + else + Set_Standard_Error; + + while Has_Next (It) loop + Next (It, D); + + Print_Diagnostic (D); + end loop; + + Set_Standard_Output; + end if; + + if Debug_Flag_Underscore_EE then + + -- Print the switch repository to a file + + Delete_File (Switches_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Switches_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_Switch_Repository; + + Set_Standard_Output; + + Close (Output_FD); + end; + + -- Print the diagnostics repository to a file + + Delete_File (Diagnostics_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Diagnostics_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_Diagnostic_Repository; + + Set_Standard_Output; + + Close (Output_FD); + end; + end if; + + Destroy (All_Diagnostics); + end Emit_Diagnostics; + +end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-converter.ads b/gcc/ada/diagnostics-converter.ads new file mode 100644 index 00000000000..8436ed19e39 --- /dev/null +++ b/gcc/ada/diagnostics-converter.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N V E R T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Converter is + + procedure Convert_Errors_To_Diagnostics; + + procedure Emit_Diagnostics; +end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/diagnostics-json_utils.adb new file mode 100644 index 00000000000..30263b0b3ca --- /dev/null +++ b/gcc/ada/diagnostics-json_utils.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . J S O N _ U T I L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Output; use Output; + +package body Diagnostics.JSON_Utils is + + ----------------- + -- Begin_Block -- + ----------------- + + procedure Begin_Block is + begin + Indent_Level := Indent_Level + 1; + end Begin_Block; + + --------------- + -- End_Block -- + --------------- + + procedure End_Block is + begin + Indent_Level := Indent_Level - 1; + end End_Block; + + procedure Indent is begin + if JSON_FORMATTING then + for I in 1 .. INDENT_SIZE * Indent_Level loop + Write_Char (' '); + end loop; + end if; + end Indent; + + ------------------- + -- NL_And_Indent -- + ------------------- + + procedure NL_And_Indent is + begin + if JSON_FORMATTING then + Write_Eol; + Indent; + end if; + end NL_And_Indent; + + ------------------------- + -- Write_Int_Attribute -- + ------------------------- + + procedure Write_Int_Attribute (Name : String; Value : Int) is + begin + Write_Str ("""" & Name & """" & ": "); + Write_Int (Value); + end Write_Int_Attribute; + + ------------------------------- + -- Write_JSON_Escaped_String -- + ------------------------------- + + procedure Write_JSON_Escaped_String (Str : String) is + begin + for C of Str loop + if C = '"' or else C = '\' then + Write_Char ('\'); + end if; + + Write_Char (C); + end loop; + end Write_JSON_Escaped_String; + + ---------------------------- + -- Write_String_Attribute -- + ---------------------------- + + procedure Write_String_Attribute (Name : String; Value : String) is + begin + Write_Str ("""" & Name & """" & ": "); + Write_Char ('"'); + Write_JSON_Escaped_String (Value); + Write_Char ('"'); + end Write_String_Attribute; + +end Diagnostics.JSON_Utils; diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/diagnostics-json_utils.ads new file mode 100644 index 00000000000..1fc6c0e315d --- /dev/null +++ b/gcc/ada/diagnostics-json_utils.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . J S O N _ U T I L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.JSON_Utils is + + JSON_FORMATTING : constant Boolean := True; + -- Adds newlines and indentation to the output JSON. + -- + -- NOTE: This flag could be associated with the gcc switch: + -- '-fno-diagnostics-json-formatting' + + INDENT_SIZE : constant := 2; + -- The number of spaces to indent each level of the JSON output. + + Indent_Level : Natural := 0; + -- The current indentation level. + + procedure Begin_Block; + -- Increase the indentation level by one + + procedure End_Block; + -- Decrease the indentation level by one + + procedure Indent; + -- Print the indentation for the line + + procedure NL_And_Indent; + -- Print a new line + + procedure Write_Int_Attribute (Name : String; Value : Int); + + procedure Write_JSON_Escaped_String (Str : String); + -- Write each character of Str, taking care of preceding each quote and + -- backslash with a backslash. Note that this escaping differs from what + -- GCC does. + -- + -- Indeed, the JSON specification mandates encoding wide characters + -- either as their direct UTF-8 representation or as their escaped + -- UTF-16 surrogate pairs representation. GCC seems to prefer escaping - + -- we choose to use the UTF-8 representation instead. + + procedure Write_String_Attribute (Name : String; Value : String); + -- Write a JSON attribute with a string value + +end Diagnostics.JSON_Utils; diff --git a/gcc/ada/diagnostics-pretty_emitter.adb b/gcc/ada/diagnostics-pretty_emitter.adb new file mode 100644 index 00000000000..927e50578e9 --- /dev/null +++ b/gcc/ada/diagnostics-pretty_emitter.adb @@ -0,0 +1,1277 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . P R E T T Y _ E M I T T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Utils; use Diagnostics.Utils; +with Output; use Output; +with Sinput; use Sinput; +with Erroutc; use Erroutc; + +package body Diagnostics.Pretty_Emitter is + + REGION_OFFSET : constant := 1; + -- Number of characters between the line bar and the region span + + REGION_ARM_SIZE : constant := 2; + -- Number of characters on the region span arms + -- e.g. two for this case: + -- +-- + -- | + -- +-- + -- ^^ + + REGION_SIZE : constant := REGION_OFFSET + 1 + REGION_ARM_SIZE; + -- The total number of characters taken up by the region span characters + + MAX_BAR_POS : constant := 7; + -- The maximum position of the line bar from the start of the line + type Printable_Line is record + First : Source_Ptr; + -- The first character of the line + + Last : Source_Ptr; + -- The last character of the line + + Line_Nr : Pos; + -- The line number + + Spans : Labeled_Span_List; + -- The spans applied on the line + end record; + + procedure Destroy (Elem : in out Printable_Line); + pragma Inline (Destroy); + + function Equals (L, R : Printable_Line) return Boolean is + (L.Line_Nr = R.Line_Nr); + + package Lines_Lists is new Doubly_Linked_Lists + (Element_Type => Printable_Line, + "=" => Equals, + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Lines_List is Lines_Lists.Doubly_Linked_List; + + type File_Sections is record + File : String_Ptr; + -- Name of the file + + Lines : Lines_List; + -- Lines to be printed for the file + end record; + + procedure Destroy (Elem : in out File_Sections); + pragma Inline (Destroy); + + function Equals (L, R : File_Sections) return Boolean is + (L.File /= null + and then R.File /= null + and then L.File.all = R.File.all); + + package File_Section_Lists is new Doubly_Linked_Lists + (Element_Type => File_Sections, + "=" => Equals, + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype File_Section_List is File_Section_Lists.Doubly_Linked_List; + + function Create_File_Sections (Spans : Labeled_Span_List) + return File_Section_List; + -- Create a list of file sections from the labeled spans that are to be + -- printed. + -- + -- Each file section contains a list of lines that are to be printed for + -- the file and the spans that are applied to each of those lines. + + procedure Create_File_Section + (Sections : in out File_Section_List; + Loc : Labeled_Span_Type); + -- Create a new file section for the given labeled span. + + procedure Add_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr); + + procedure Create_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr); + -- Create a new printable line for the given labeled span and add it in the + -- correct position to the Lines list based on the line number. + + function Has_Region_Span_Start (L : Printable_Line) return Boolean; + function Has_Region_Span_End (L : Printable_Line) return Boolean; + + function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean; + + procedure Write_Region_Delimiter; + -- Write the arms signifying the start and end of a region span + -- e.g. +-- + + procedure Write_Region_Bar; + -- Write the bar signifying the continuation of a region span + -- e.g. | + + procedure Write_Region_Continuation; + -- Write the continuation signifying the continuation of a region span + -- e.g. : + + procedure Write_Region_Offset; + -- Write a number of whitespaces equal to the size of the region span + + function Trimmed_Image (I : Natural) return String; + + procedure Write_Span_Labels (Loc : Labeled_Span_Type; + L : Printable_Line; + Line_Size : Integer; + Idx : String; + Within_Region_Span : Boolean); + + procedure Write_File_Section (Sec : File_Sections; + Write_File_Name : Boolean; + File_Name_Offset : Integer); + + procedure Write_Labeled_Spans (Spans : Labeled_Span_List; + Write_File_Name : Boolean; + File_Name_Offset : Integer); + + procedure Write_Intersecting_Labels + (Intersecting_Labels : Labeled_Span_List); + + function Get_Line_End + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the end of the line in Buf for Loc. If + -- Loc is past the end of Buf already, return Buf'Last. + + function Get_Line_Start + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the start of the line in Buf for Loc + + function Get_First_Line_Char + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; + -- Get first non-space character in the line containing Loc + + function Image (X : Positive; Width : Positive) return String; + -- Output number X over Width characters, with whitespace padding. + -- Only output the low-order Width digits of X, if X is larger than + -- Width digits. + + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr); + -- Output the characters from First to Last position in Buf, using + -- Write_Buffer_Char. + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr); + -- Output the characters at position Loc in Buf, translating ASCII.HT + -- in a suitable number of spaces so that the output is not modified + -- by starting in a different column that 1. + + procedure Write_Line_Marker + (Num : Pos; + Width : Positive); + + procedure Write_Empty_Bar_Line (Width : Integer); + + procedure Write_Empty_Skip_Line (Width : Integer); + + procedure Write_Error_Msg_Line (Diag : Diagnostic_Type); + -- Write the error message line for the given diagnostic: + -- + -- '['']' : ['['']'] + + function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) return Boolean; + -- If the sub-diagnostic and the main diagnostic only point to the same + -- file then there is no reason to add the file name to the sub-diagnostic. + + function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean; + -- Old sub-diagnostics used to have the same location as the main + -- diagnostic in order to group them correctly. However in most cases + -- it was not meant to point to a location but rather add an additional + -- message to the original diagnostic. + -- + -- If the sub-diagnostic and the main diagnostic have the same location + -- then we should avoid printing the spans. + + procedure Print_Edit + (Edit : Edit_Type; + Offset : Integer); + + procedure Print_Fix + (Fix : Fix_Type; + Offset : Integer); + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type; + Offset : Integer); + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Printable_Line) + is + begin + -- Diagnostic elements will be freed when all the diagnostics have been + -- emitted. + null; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out File_Sections) + is + begin + Free (Elem.File); + end Destroy; + + ------------------ + -- Get_Line_End -- + ------------------ + + function Get_Line_End + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last); + begin + while Cur_Loc < Buf'Last + and then Buf (Cur_Loc) /= ASCII.LF + loop + Cur_Loc := Cur_Loc + 1; + end loop; + + return Cur_Loc; + end Get_Line_End; + + -------------------- + -- Get_Line_Start -- + -------------------- + + function Get_Line_Start + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Loc; + begin + while Cur_Loc > Buf'First + and then Buf (Cur_Loc - 1) /= ASCII.LF + loop + Cur_Loc := Cur_Loc - 1; + end loop; + + return Cur_Loc; + end Get_Line_Start; + + ------------------------- + -- Get_First_Line_Char -- + ------------------------- + + function Get_First_Line_Char + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Get_Line_Start (Buf, Loc); + begin + while Cur_Loc < Buf'Last + and then Buf (Cur_Loc) = ' ' + loop + Cur_Loc := Cur_Loc + 1; + end loop; + + return Cur_Loc; + end Get_First_Line_Char; + + ----------- + -- Image -- + ----------- + + function Image (X : Positive; Width : Positive) return String is + Str : String (1 .. Width); + Curr : Natural := X; + begin + for J in reverse 1 .. Width loop + if Curr > 0 then + Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10); + Curr := Curr / 10; + else + Str (J) := ' '; + end if; + end loop; + + return Str; + end Image; + + -------------------------------- + -- Has_Multiple_Labeled_Spans -- + -------------------------------- + + function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean + is + Count : Natural := 0; + + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + if Loc.Label /= null then + Count := Count + 1; + end if; + end loop; + + return Count > 1; + end Has_Multiple_Labeled_Spans; + + --------------------------- + -- Has_Region_Span_Start -- + --------------------------- + + function Has_Region_Span_Start (L : Printable_Line) return Boolean is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Has_Region_Start : Boolean := False; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if not Has_Region_Start + and then Loc.Is_Region + and then L.Line_Nr = + Pos (Get_Physical_Line_Number (Loc.Span.First)) + then + Has_Region_Start := True; + end if; + end loop; + return Has_Region_Start; + end Has_Region_Span_Start; + + ------------------------- + -- Has_Region_Span_End -- + ------------------------- + + function Has_Region_Span_End (L : Printable_Line) return Boolean is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Has_Region_End : Boolean := False; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if not Has_Region_End + and then Loc.Is_Region + and then L.Line_Nr = + Pos (Get_Physical_Line_Number (Loc.Span.Last)) + then + Has_Region_End := True; + end if; + end loop; + return Has_Region_End; + end Has_Region_Span_End; + + ------------------ + -- Write_Buffer -- + ------------------ + + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr) + is + begin + for Loc in First .. Last loop + Write_Buffer_Char (Buf, Loc); + end loop; + end Write_Buffer; + + ----------------------- + -- Write_Buffer_Char -- + ----------------------- + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) + is + begin + -- If the character ASCII.HT is not the last one in the file, + -- output as many spaces as the character represents in the + -- original source file. + + if Buf (Loc) = ASCII.HT + and then Loc < Buf'Last + then + for X in Get_Column_Number (Loc) .. + Get_Column_Number (Loc + 1) - 1 + loop + Write_Char (' '); + end loop; + + -- Otherwise output the character itself + + else + Write_Char (Buf (Loc)); + end if; + end Write_Buffer_Char; + + ----------------------- + -- Write_Line_Marker -- + ----------------------- + + procedure Write_Line_Marker + (Num : Pos; + Width : Positive) + is + begin + Write_Str (Image (Positive (Num), Width => Width - 2)); + Write_Str (" |"); + end Write_Line_Marker; + + -------------------------- + -- Write_Empty_Bar_Line -- + -------------------------- + + procedure Write_Empty_Bar_Line (Width : Integer) is + + begin + Write_Str (String'(1 .. Width - 1 => ' ')); + Write_Str ("|"); + end Write_Empty_Bar_Line; + + --------------------------- + -- Write_Empty_Skip_Line -- + --------------------------- + + procedure Write_Empty_Skip_Line (Width : Integer) is + + begin + Write_Str (String'(1 .. Width - 1 => ' ')); + Write_Str (":"); + end Write_Empty_Skip_Line; + + ---------------------------- + -- Write_Region_Delimiter -- + ---------------------------- + + procedure Write_Region_Delimiter is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str ("+"); + Write_Str (String'(1 .. REGION_ARM_SIZE => '-')); + end Write_Region_Delimiter; + + ---------------------- + -- Write_Region_Bar -- + ---------------------- + + procedure Write_Region_Bar is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str ("|"); + Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); + end Write_Region_Bar; + + ------------------------------- + -- Write_Region_Continuation -- + ------------------------------- + + procedure Write_Region_Continuation is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (":"); + Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); + end Write_Region_Continuation; + + ------------------------- + -- Write_Region_Offset -- + ------------------------- + + procedure Write_Region_Offset is + + begin + Write_Str (String'(1 .. REGION_SIZE => ' ')); + end Write_Region_Offset; + + ------------------------ + -- Add_Printable_Line -- + ------------------------ + + procedure Add_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr) + is + L : Printable_Line; + L_It : Lines_Lists.Iterator; + + Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); + Line_Found : Boolean := False; + begin + L_It := Lines_Lists.Iterate (Lines); + while Lines_Lists.Has_Next (L_It) loop + Lines_Lists.Next (L_It, L); + + if not Line_Found and then L.Line_Nr = Line_Ptr then + if not Labeled_Span_Lists.Contains (L.Spans, Loc) then + Labeled_Span_Lists.Append (L.Spans, Loc); + end if; + Line_Found := True; + end if; + end loop; + + if not Line_Found then + Create_Printable_Line (Lines, Loc, S_Ptr); + end if; + end Add_Printable_Line; + + --------------------------- + -- Create_Printable_Line -- + --------------------------- + + procedure Create_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr) + is + Spans : constant Labeled_Span_List := Labeled_Span_Lists.Create; + + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (S_Ptr)); + + Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); + + New_Line : constant Printable_Line := + (First => Get_Line_Start (Buf, S_Ptr), + Last => Get_Line_End (Buf, S_Ptr), + Line_Nr => Line_Nr, + Spans => Spans); + + L : Printable_Line; + L_It : Lines_Lists.Iterator := Lines_Lists.Iterate (Lines); + + Found_Greater_Line : Boolean := False; + Insert_Before_Line : Printable_Line; + begin + Labeled_Span_Lists.Append (Spans, Loc); + + -- Insert the new line based on the line number + + while Lines_Lists.Has_Next (L_It) loop + Lines_Lists.Next (L_It, L); + + if not Found_Greater_Line + and then L.Line_Nr > New_Line.Line_Nr + then + Found_Greater_Line := True; + Insert_Before_Line := L; + + Lines_Lists.Insert_Before (Lines, Insert_Before_Line, New_Line); + end if; + end loop; + + if Found_Greater_Line then + + -- Insert after all the lines have been iterated over to avoid the + -- mutation lock in GNAT.Lists + + null; + else + Lines_Lists.Append (Lines, New_Line); + end if; + end Create_Printable_Line; + + ------------------------- + -- Create_File_Section -- + ------------------------- + + procedure Create_File_Section + (Sections : in out File_Section_List; Loc : Labeled_Span_Type) + is + Lines : constant Lines_List := Lines_Lists.Create; + + -- Carret positions + Ptr : constant Source_Ptr := Loc.Span.Ptr; + Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); + + -- Span start positions + Fst : constant Source_Ptr := Loc.Span.First; + Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Loc.Span.Last; + Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); + begin + Create_Printable_Line (Lines, Loc, Fst); + + if Line_Fst /= Line_Ptr then + Create_Printable_Line (Lines, Loc, Ptr); + end if; + + if Line_Ptr /= Line_Lst then + Create_Printable_Line (Lines, Loc, Lst); + end if; + + File_Section_Lists.Append + (Sections, + (File => new String'(To_File_Name (Loc.Span.Ptr)), + Lines => Lines)); + end Create_File_Section; + + -------------------------- + -- Create_File_Sections -- + -------------------------- + + function Create_File_Sections + (Spans : Labeled_Span_List) return File_Section_List + is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Spans); + + Sections : File_Section_List := File_Section_Lists.Create; + + Sec : File_Sections; + F_It : File_Section_Lists.Iterator; + + File_Found : Boolean; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + File_Found := False; + F_It := File_Section_Lists.Iterate (Sections); + + while File_Section_Lists.Has_Next (F_It) loop + File_Section_Lists.Next (F_It, Sec); + + if Sec.File /= null + and then Sec.File.all = To_File_Name (Loc.Span.Ptr) + then + File_Found := True; + + Add_Printable_Line (Sec.Lines, Loc, Loc.Span.First); + + Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Ptr); + + Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Last); + end if; + end loop; + + if not File_Found then + Create_File_Section (Sections, Loc); + end if; + end loop; + + return Sections; + end Create_File_Sections; + + ----------------------- + -- Write_Span_Labels -- + ----------------------- + + procedure Write_Span_Labels (Loc : Labeled_Span_Type; + L : Printable_Line; + Line_Size : Integer; + Idx : String; + Within_Region_Span : Boolean) + is + Span_Char : constant Character := (if Loc.Is_Primary then '~' else '-'); + + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (L.First)); + + Col_L_Fst : constant Natural := Natural + (Get_Column_Number (Get_First_Line_Char (Buf, L.First))); + Col_L_Lst : constant Natural := Natural (Get_Column_Number (L.Last)); + + -- Carret positions + Ptr : constant Source_Ptr := Loc.Span.Ptr; + Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); + Col_Ptr : constant Natural := Natural (Get_Column_Number (Ptr)); + + -- Span start positions + Fst : constant Source_Ptr := Loc.Span.First; + Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Natural := Natural (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Loc.Span.Last; + Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Natural := Natural (Get_Column_Number (Lst)); + + -- Attributes for the span on the current line + + Span_Sym : constant String := (if Idx = "" then "^" else Idx); + + Span_Fst : constant Natural := + (if Line_Fst = L.Line_Nr then Col_Fst else Col_L_Fst); + + Span_Lst : constant Natural := + (if Line_Lst = L.Line_Nr then Col_Lst else Col_L_Lst); + + Span_Ptr_Fst : constant Natural := + (if Line_Ptr = L.Line_Nr then Col_Ptr else Col_L_Fst); + + Span_Ptr_Lst : constant Natural := + (if Line_Ptr = L.Line_Nr + then Span_Ptr_Fst + Span_Sym'Length + else Span_Fst); + + begin + if not Loc.Is_Region then + Write_Empty_Bar_Line (Line_Size); + + if Within_Region_Span then + Write_Region_Bar; + else + Write_Region_Offset; + end if; + + Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + + if Line_Ptr = L.Line_Nr then + Write_Str (String'(Span_Fst .. Col_Ptr - 1 => Span_Char)); + Write_Str (Span_Sym); + end if; + + Write_Str (String'(Span_Ptr_Lst .. Span_Lst => Span_Char)); + + Write_Eol; + + -- Write the label under the line unless it is an intersecting span. + -- In this case omit the label which will be printed later along with + -- the index. + + if Loc.Label /= null and then Idx = "" then + Write_Empty_Bar_Line (Line_Size); + + if Within_Region_Span then + Write_Region_Bar; + else + Write_Region_Offset; + end if; + + Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + Write_Str (Loc.Label.all); + Write_Eol; + end if; + else + if Line_Lst = L.Line_Nr then + Write_Empty_Bar_Line (Line_Size); + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (Loc.Label.all); + Write_Eol; + end if; + end if; + + end Write_Span_Labels; + + ------------------- + -- Trimmed_Image -- + ------------------- + + function Trimmed_Image (I : Natural) return String is + Img_Raw : constant String := Natural'Image (I); + begin + return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Trimmed_Image; + + ------------------------------- + -- Write_Intersecting_Labels -- + ------------------------------- + + procedure Write_Intersecting_Labels + (Intersecting_Labels : Labeled_Span_List) + is + Ls : Labeled_Span_Type; + Ls_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Intersecting_Labels); + Idx : Integer := 0; + begin + while Labeled_Span_Lists.Has_Next (Ls_It) loop + Labeled_Span_Lists.Next (Ls_It, Ls); + Idx := Idx + 1; + + Write_Empty_Bar_Line (MAX_BAR_POS); + Write_Str (" "); + Write_Int (Int (Idx)); + Write_Str (": "); + Write_Str (Ls.Label.all); + Write_Eol; + end loop; + end Write_Intersecting_Labels; + + ------------------------ + -- Write_File_Section -- + ------------------------ + + procedure Write_File_Section (Sec : File_Sections; + Write_File_Name : Boolean; + File_Name_Offset : Integer) + is + use Lines_Lists; + + L : Printable_Line; + L_It : Iterator := Iterate (Sec.Lines); + + -- The error should be included in the first (primary) span of the file. + Loc : constant Labeled_Span_Type := + Labeled_Span_Lists.First (Lines_Lists.First (Sec.Lines).Spans); + + Multiple_Labeled_Spans : Boolean := False; + + Idx : Integer := 0; + + Intersecting_Labels : constant Labeled_Span_List := + Labeled_Span_Lists.Create; + + Prev_Line_Nr : Natural := 0; + + Within_Region_Span : Boolean := False; + begin + if Write_File_Name then + + -- offset the file start location for sub-diagnostics + + Write_Str (String'(1 .. File_Name_Offset => ' ')); + Write_Str ("--> " & To_String (Loc.Span.Ptr)); + Write_Eol; + end if; + + while Has_Next (L_It) loop + Next (L_It, L); + declare + Line_Nr : constant Pos := L.Line_Nr; + Line_Str : constant String := Trimmed_Image (Natural (Line_Nr)); + + Line_Size : constant Integer := + Integer'Max (Line_Str'Length, MAX_BAR_POS); + + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (L.First)); + + Contains_Region_Span_Start : constant Boolean := + Has_Region_Span_Start (L); + Contains_Region_Span_End : constant Boolean := + Has_Region_Span_End (L); + begin + if not Multiple_Labeled_Spans then + Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L); + end if; + + -- Write an empty line with the continuation symbol if the line + -- numbers are not contiguous + + if Prev_Line_Nr /= 0 + and then Pos (Prev_Line_Nr + 1) /= Line_Nr + then + Write_Empty_Skip_Line (Line_Size); + + if Within_Region_Span then + Write_Region_Continuation; + end if; + + Write_Eol; + end if; + + if Contains_Region_Span_Start then + Within_Region_Span := True; + end if; + + Write_Line_Marker (Line_Nr, Line_Size); + + -- Write either the region span symbol or the same number of + -- whitespaces. + + if Contains_Region_Span_Start or Contains_Region_Span_End then + Write_Region_Delimiter; + elsif Within_Region_Span then + Write_Region_Bar; + else + Write_Region_Offset; + end if; + + -- Write the line itself + + Write_Buffer + (Buf => Buf, + First => L.First, + Last => L.Last); + + -- Write all the spans for the line + + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if Multiple_Labeled_Spans + and then Loc.Label /= null + then + + -- Collect all the spans with labels to print them at the + -- end. + + Labeled_Span_Lists.Append (Intersecting_Labels, Loc); + + Idx := Idx + 1; + + Write_Span_Labels (Loc, + L, + Line_Size, + Trimmed_Image (Idx), + Within_Region_Span); + else + Write_Span_Labels (Loc, + L, + Line_Size, + "", + Within_Region_Span); + end if; + + end loop; + + if Contains_Region_Span_End then + Within_Region_Span := False; + end if; + + Prev_Line_Nr := Natural (Line_Nr); + end; + end loop; + + Write_Intersecting_Labels (Intersecting_Labels); + end Write_File_Section; + + ------------------------- + -- Write_Labeled_Spans -- + ------------------------- + + procedure Write_Labeled_Spans (Spans : Labeled_Span_List; + Write_File_Name : Boolean; + File_Name_Offset : Integer) + is + Sections : File_Section_List := Create_File_Sections (Spans); + + Sec : File_Sections; + F_It : File_Section_Lists.Iterator := + File_Section_Lists.Iterate (Sections); + begin + while File_Section_Lists.Has_Next (F_It) loop + File_Section_Lists.Next (F_It, Sec); + + Write_File_Section + (Sec, Write_File_Name, File_Name_Offset); + end loop; + + File_Section_Lists.Destroy (Sections); + end Write_Labeled_Spans; + + -------------------------- + -- Write_Error_Msg_Line -- + -------------------------- + + procedure Write_Error_Msg_Line (Diag : Diagnostic_Type) is + Switch_Str : constant String := Get_Doc_Switch (Diag); + + Kind_Str : constant String := Kind_To_String (Diag); + + SGR_Code : constant String := + (if Kind_Str = "error" then SGR_Error + elsif Kind_Str = "warning" then SGR_Warning + elsif Kind_Str = "info" then SGR_Note + else SGR_Reset); + begin + Write_Str (SGR_Code); + + Write_Str ("[" & To_String (Diag.Id) & "]"); + + Write_Str (" " & Kind_To_String (Diag) & ": "); + + Write_Str (SGR_Reset); + + Write_Str (Diag.Message.all); + + if Switch_Str /= "" then + Write_Str (" " & Switch_Str); + end if; + + if Diag.Warn_Err then + Write_Str (" [warning-as-error]"); + end if; + + Write_Eol; + end Write_Error_Msg_Line; + + ---------------------------- + -- Should_Write_File_Name -- + ---------------------------- + + function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean + is + Sub_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Sub_Diag.Locations); + + Diag_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Diag.Locations); + + function Has_Multiple_Files (Spans : Labeled_Span_List) return Boolean; + + ------------------------ + -- Has_Multiple_Files -- + ------------------------ + + function Has_Multiple_Files + (Spans : Labeled_Span_List) return Boolean + is + First : constant Labeled_Span_Type := + Labeled_Span_Lists.First (Spans); + + File : constant String := To_File_Name (First.Span.Ptr); + + Loc : Labeled_Span_Type; + It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Spans); + + begin + while Labeled_Span_Lists.Has_Next (It) loop + Labeled_Span_Lists.Next (It, Loc); + + if To_File_Name (Loc.Span.Ptr) /= File then + return True; + end if; + end loop; + return False; + end Has_Multiple_Files; + begin + return + Has_Multiple_Files (Diag.Locations) + or else To_File_Name (Sub_Loc.Span.Ptr) /= + To_File_Name (Diag_Loc.Span.Ptr); + end Should_Write_File_Name; + + ------------------------ + -- Should_Write_Spans -- + ------------------------ + + function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean + is + Sub_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Sub_Diag.Locations); + + Diag_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Diag.Locations); + begin + return Sub_Loc /= No_Labeled_Span + and then Diag_Loc /= No_Labeled_Span + and then Sub_Loc.Span.Ptr /= Diag_Loc.Span.Ptr; + end Should_Write_Spans; + + ---------------- + -- Print_Edit -- + ---------------- + + procedure Print_Edit (Edit : Edit_Type; Offset : Integer) is + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Edit.Span.Ptr)); + + Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (Edit.Span.Ptr)); + + Line_Fst : constant Source_Ptr := Get_Line_Start (Buf, Edit.Span.First); + Line_Lst : constant Source_Ptr := Get_Line_End (Buf, Edit.Span.First); + begin + Write_Str (String'(1 .. Offset => ' ')); + Write_Str ("--> " & To_File_Name (Edit.Span.Ptr)); + Write_Eol; + + -- write the original line + + Write_Char ('-'); + Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); + + Write_Buffer + (Buf => Buf, + First => Line_Fst, + Last => Line_Lst); + + -- write the edited line + + Write_Char ('+'); + Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); + + Write_Buffer + (Buf => Buf, + First => Line_Fst, + Last => Edit.Span.First - 1); + + if Edit.Text /= null then + Write_Str (Edit.Text.all); + end if; + + Write_Buffer + (Buf => Buf, + First => Edit.Span.Last + 1, + Last => Line_Lst); + + end Print_Edit; + + --------------- + -- Print_Fix -- + --------------- + + procedure Print_Fix (Fix : Fix_Type; Offset : Integer) is + use Edit_Lists; + begin + Write_Str (String'(1 .. Offset => ' ')); + Write_Str ("+ Fix: "); + + if Fix.Description /= null then + Write_Str (Fix.Description.all); + end if; + Write_Eol; + + if Present (Fix.Edits) then + declare + Edit : Edit_Type; + + It : Iterator := Iterate (Fix.Edits); + begin + while Has_Next (It) loop + Next (It, Edit); + + Print_Edit (Edit, MAX_BAR_POS - 1); + end loop; + end; + end if; + end Print_Fix; + + -------------------------- + -- Print_Sub_Diagnostic -- + -------------------------- + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type; + Offset : Integer) + is + begin + Write_Str (String'(1 .. Offset => ' ')); + + if Sub_Diag.Kind = Suggestion then + Write_Str ("+ Suggestion: "); + else + Write_Str ("+ "); + end if; + + Write_Str (Sub_Diag.Message.all); + Write_Eol; + + if Should_Write_Spans (Sub_Diag, Diag) then + Write_Labeled_Spans (Sub_Diag.Locations, + Should_Write_File_Name (Sub_Diag, Diag), + Offset); + end if; + end Print_Sub_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diag : Diagnostic_Type) is + + begin + -- Print the main diagnostic + + Write_Error_Msg_Line (Diag); + + -- Print diagnostic locations along with spans + + Write_Labeled_Spans (Diag.Locations, True, 0); + + -- Print subdiagnostics + + if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then + declare + use Sub_Diagnostic_Lists; + Sub_Diag : Sub_Diagnostic_Type; + + It : Iterator := Iterate (Diag.Sub_Diagnostics); + begin + while Has_Next (It) loop + Next (It, Sub_Diag); + + -- Print the subdiagnostic and offset the location of the file + -- name + + Print_Sub_Diagnostic (Sub_Diag, Diag, MAX_BAR_POS - 1); + end loop; + end; + end if; + + -- Print fixes + + if Fix_Lists.Present (Diag.Fixes) then + declare + use Fix_Lists; + Fix : Fix_Type; + + It : Iterator := Iterate (Diag.Fixes); + begin + while Has_Next (It) loop + Next (It, Fix); + + Print_Fix (Fix, MAX_BAR_POS - 1); + end loop; + end; + end if; + + -- Separate main diagnostics with a blank line + + Write_Eol; + + end Print_Diagnostic; +end Diagnostics.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-pretty_emitter.ads b/gcc/ada/diagnostics-pretty_emitter.ads new file mode 100644 index 00000000000..5f46e34a9e2 --- /dev/null +++ b/gcc/ada/diagnostics-pretty_emitter.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . P R E T T Y _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Pretty_Emitter is + procedure Print_Diagnostic (Diag : Diagnostic_Type); +end Diagnostics.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-repository.adb b/gcc/ada/diagnostics-repository.adb new file mode 100644 index 00000000000..dca38e947b6 --- /dev/null +++ b/gcc/ada/diagnostics-repository.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . R E P O S I T O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Diagnostics.Utils; use Diagnostics.Utils; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Output; use Output; + +package body Diagnostics.Repository is + + --------------------------------- + -- Print_Diagnostic_Repository -- + --------------------------------- + + procedure Print_Diagnostic_Repository is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & "Diagnostics" & """" & ": " & "["); + Begin_Block; + + -- Avoid printing the first switch, which is a placeholder + + for I in Diagnostic_Entries'First .. Diagnostic_Entries'Last loop + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("Id", To_String (I)); + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Human_Id /= null then + Write_String_Attribute ("Human_Id", + Diagnostic_Entries (I).Human_Id.all); + else + Write_String_Attribute ("Human_Id", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Status = Active then + Write_String_Attribute ("Status", "Active"); + else + Write_String_Attribute ("Status", "Deprecated"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Documentation /= null then + Write_String_Attribute ("Documentation", + Diagnostic_Entries (I).Documentation.all); + else + Write_String_Attribute ("Documentation", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Switch /= No_Switch_Id then + Write_Char (','); + NL_And_Indent; + Write_String_Attribute + ("Switch", + Get_Switch (Diagnostic_Entries (I).Switch).Human_Id.all); + else + Write_String_Attribute ("Switch", "null"); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_Diagnostic_Repository; + +end Diagnostics.Repository; diff --git a/gcc/ada/diagnostics-repository.ads b/gcc/ada/diagnostics-repository.ads new file mode 100644 index 00000000000..b070fda0269 --- /dev/null +++ b/gcc/ada/diagnostics-repository.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . R E P O S I T O R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +package Diagnostics.Repository is + + type Diagnostics_Registry_Type is + array (Diagnostic_Id) of Diagnostic_Entry_Type; + + -- Include the diagnostic entries for every diagnostic id. + -- The entries should include: + -- * Whether the diagnostic with this id is active or not + -- * The human-readable name for the diagnostic for SARIF reports + -- * The switch id for the diagnostic if the diagnostic is linked to any + -- compiler switch + -- * The documentation file for the diagnostic written in the MD format. + -- The documentation file should include: + -- - The diagnostic id + -- - A short description of the diagnostic + -- - A minimal example of the code that triggers the diagnostic + -- - An explanation of why the diagnostic was triggered + -- - A suggestion on how to fix the issue + -- - Optionally additional information + -- TODO: the mandatory fields for the documentation file could be changed + + Diagnostic_Entries : Diagnostics_Registry_Type := + (No_Diagnostic_Id => (others => <>), + GNAT0001 => + (Status => Active, + Human_Id => new String'("Default_Iterator_Not_Primitive_Error"), + Documentation => new String'("./error_codes/GNAT0001.md"), + Switch => No_Switch_Id), + GNAT0002 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_For_Operator_Error"), + Documentation => new String'("./error_codes/GNAT0002.md"), + Switch => No_Switch_Id), + GNAT0003 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Left_To_Int_Error"), + Documentation => new String'("./error_codes/GNAT0003.md"), + Switch => No_Switch_Id), + GNAT0004 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Right_To_Int_Error"), + Documentation => new String'("./error_codes/GNAT0004.md"), + Switch => No_Switch_Id), + GNAT0005 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Left_Acc_Error"), + Documentation => new String'("./error_codes/GNAT0005.md"), + Switch => No_Switch_Id), + GNAT0006 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Right_Acc_Error"), + Documentation => new String'("./error_codes/GNAT0006.md"), + Switch => No_Switch_Id), + GNAT0007 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_General_Error"), + Documentation => new String'("./error_codes/GNAT0007.md"), + Switch => No_Switch_Id), + GNAT0008 => + (Status => Active, + Human_Id => + new String'("Pragma_No_Effect_With_Lock_Free_Warning"), + Documentation => new String'("./error_codes/GNAT0008.md"), + Switch => No_Switch_Id), + GNAT0009 => + (Status => Active, + Human_Id => new String'("End_Loop_Expected_Error"), + Documentation => new String'("./error_codes/GNAT0009.md"), + Switch => No_Switch_Id), + GNAT0010 => + (Status => Active, + Human_Id => new String'("Representation_Too_Late_Error"), + Documentation => new String'("./error_codes/GNAT0010.md"), + Switch => No_Switch_Id)); + + procedure Print_Diagnostic_Repository; + +end Diagnostics.Repository; diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/diagnostics-sarif_emitter.adb new file mode 100644 index 00000000000..cbb423b2e1d --- /dev/null +++ b/gcc/ada/diagnostics-sarif_emitter.adb @@ -0,0 +1,1090 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . S A R I F _ E M I T T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Utils; use Diagnostics.Utils; +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Gnatvsn; use Gnatvsn; +with Output; use Output; +with Sinput; use Sinput; + +package body Diagnostics.SARIF_Emitter is + + type Artifact_Change is record + File : String_Ptr; + -- Name of the file + + Replacements : Edit_List; + -- Regions of texts to be edited + end record; + + procedure Destroy (Elem : in out Artifact_Change); + pragma Inline (Destroy); + + function Equals (L, R : Artifact_Change) return Boolean is + (L.File /= null + and then R.File /= null + and then L.File.all = R.File.all); + + package Artifact_Change_Lists is new Doubly_Linked_Lists + (Element_Type => Artifact_Change, + "=" => Equals, + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Artifact_Change_List is Artifact_Change_Lists.Doubly_Linked_List; + + function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List; + -- Group edits of a Fix into Artifact_Changes that organize the edits by + -- file name. + + function Get_Unique_Rules (Diags : Diagnostic_List) return Diagnostic_List; + -- Get a list of diagnostics that have unique Diagnostic Id-s. + + procedure Print_Replacement (Replacement : Edit_Type); + -- Print a replacement node + -- + -- { + -- deletedRegion: {}, + -- insertedContent: {} + -- } + + procedure Print_Fix (Fix : Fix_Type); + -- Print the fix node + -- + -- { + -- description: {}, + -- artifactChanges: [] + -- } + + procedure Print_Fixes (Diag : Diagnostic_Type); + -- Print the fixes node + -- + -- "fixes": [ + -- , + -- ... + -- ] + + procedure Print_Artifact_Change (A : Artifact_Change); + -- Print an ArtifactChange node + -- + -- { + -- artifactLocation: {}, + -- replacements: [] + -- } + + procedure Print_Artifact_Location (File_Name : String); + -- Print an artifactLocation node + -- + -- "artifactLocation": { + -- "URI": + -- } + + procedure Print_Location (Loc : Labeled_Span_Type; + Msg : String_Ptr); + -- Print a location node that consists of + -- * an optional message node + -- * a physicalLocation node + -- * ArtifactLocation node that consists of the file name + -- * Region node that consists of the start and end positions of the span + -- + -- { + -- "message": { + -- "text": + -- }, + -- "physicalLocation": { + -- "artifactLocation": { + -- "URI": + -- }, + -- "region": { + -- "startLine": , + -- "startColumn": , + -- "endLine": , + -- "endColumn": Col(Loc.Lst)> + -- } + -- } + -- } + + procedure Print_Locations (Diag : Diagnostic_Type); + -- Print a locations node that consists of multiple location nodes. However + -- typically just one location for the primary span of the diagnostic. + -- + -- "locations": [ + -- + -- ], + + procedure Print_Message (Text : String; Name : String := "message"); + -- Print a SARIF message node + -- + -- "message": { + -- "text": + -- }, + + procedure Print_Related_Locations (Diag : Diagnostic_Type); + -- Print a relatedLocations node that consists of multiple location nodes. + -- Related locations are the non-primary spans of the diagnostic and the + -- primary locations of sub-diagnostics. + -- + -- "relatedLocations": [ + -- + -- ], + + procedure Print_Region (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := "region"); + -- Print a region node. + -- + -- More specifically a text region node that specifies the textual + -- location of the region. Note that in SARIF there are also binary + -- regions. + -- + -- "": { + -- "startLine": Start_Line, + -- "startColumn": Start_Col, + -- "endLine": End_Line, + -- "endColumn": End_Col + 1 + -- } + -- + -- Note that there are many types of nodes that can have a region type, + -- but have a different node name. + -- + -- The end column is defined differently in the SARIF report than it is + -- for the spans within GNAT. Internally we consider the end column of a + -- span to be the last character of the span. + -- + -- However in SARIF the end column is defined as: + -- "The column number of the character following the end of the region" + -- + -- This method assumes that the End_Col passed to this procedure is using + -- the GNAT span definition and we amend the endColumn value so that it + -- matches the SARIF definition. + + procedure Print_Result (Diag : Diagnostic_Type); + -- { + -- "ruleId": , + -- "level": , + -- "message": { + -- "text": + -- }, + -- "locations": [], + -- "relatedLocations": [] + -- }, + + procedure Print_Results (Diags : Diagnostic_List); + -- Print a results node that consists of multiple result nodes for each + -- diagnostic instance. + -- + -- "results": [ + -- + -- ] + + procedure Print_Rule (Diag : Diagnostic_Type); + -- Print a rule node that consists of the following attributes: + -- * ruleId + -- * level + -- * name + -- + -- { + -- "id": , + -- "level": , + -- "name": + -- }, + + procedure Print_Rules (Diags : Diagnostic_List); + -- Print a rules node that consists of multiple rule nodes. + -- Rules are considered to be a set of unique diagnostics with the unique + -- id-s. + -- + -- "rules": [ + -- + -- ] + + procedure Print_Runs (Diags : Diagnostic_List); + -- Print a runs node that can consist of multiple run nodes. + -- However for our report it consists of a single run that consists of + -- * a tool node + -- * a results node + -- + -- { + -- "tool": { }, + -- "results": [] + -- } + + procedure Print_Tool (Diags : Diagnostic_List); + -- Print a tool node that consists of + -- * a driver node that consists of: + -- * name + -- * version + -- * rules + -- + -- "tool": { + -- "driver": { + -- "name": "GNAT", + -- "version": , + -- "rules": [] + -- } + -- } + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Artifact_Change) + is + + begin + Free (Elem.File); + end Destroy; + + -------------------------- + -- Get_Artifact_Changes -- + -------------------------- + + function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List + is + procedure Insert (Changes : Artifact_Change_List; E : Edit_Type); + + ------------ + -- Insert -- + ------------ + + procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) + is + A : Artifact_Change; + + It : Artifact_Change_Lists.Iterator := + Artifact_Change_Lists.Iterate (Changes); + begin + while Artifact_Change_Lists.Has_Next (It) loop + Artifact_Change_Lists.Next (It, A); + + if A.File.all = To_File_Name (E.Span.Ptr) then + Edit_Lists.Append (A.Replacements, E); + return; + end if; + end loop; + + declare + Replacements : constant Edit_List := Edit_Lists.Create; + begin + Edit_Lists.Append (Replacements, E); + Artifact_Change_Lists.Append + (Changes, + (File => new String'(To_File_Name (E.Span.Ptr)), + Replacements => Replacements)); + end; + end Insert; + + Changes : constant Artifact_Change_List := Artifact_Change_Lists.Create; + + E : Edit_Type; + + It : Edit_Lists.Iterator := Edit_Lists.Iterate (Fix.Edits); + begin + while Edit_Lists.Has_Next (It) loop + Edit_Lists.Next (It, E); + + Insert (Changes, E); + end loop; + + return Changes; + end Get_Artifact_Changes; + + ---------------------- + -- Get_Unique_Rules -- + ---------------------- + + function Get_Unique_Rules (Diags : Diagnostic_List) + return Diagnostic_List + is + use Diagnostics.Diagnostics_Lists; + + procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type); + + ------------ + -- Insert -- + ------------ + + procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type) is + It : Iterator := Iterate (Rules); + R : Diagnostic_Type; + begin + while Has_Next (It) loop + Next (It, R); + + if R.Id = D.Id then + return; + elsif R.Id > D.Id then + Insert_Before (Rules, R, D); + return; + end if; + end loop; + + Append (Rules, D); + end Insert; + + D : Diagnostic_Type; + Unique_Rules : constant Diagnostic_List := Create; + + It : Iterator := Iterate (Diags); + begin + if Present (Diags) then + while Has_Next (It) loop + Next (It, D); + Insert (Unique_Rules, D); + end loop; + end if; + + return Unique_Rules; + end Get_Unique_Rules; + + --------------------------- + -- Print_Artifact_Change -- + --------------------------- + + procedure Print_Artifact_Change (A : Artifact_Change) + is + use Diagnostics.Edit_Lists; + E : Edit_Type; + E_It : Iterator; + + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print artifactLocation + + Print_Artifact_Location (A.File.all); + + Write_Char (','); + NL_And_Indent; + + Write_Str ("""" & "replacements" & """" & ": " & "["); + Begin_Block; + NL_And_Indent; + + E_It := Iterate (A.Replacements); + + while Has_Next (E_It) loop + Next (E_It, E); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Replacement (E); + end loop; + + -- End replacements + + End_Block; + NL_And_Indent; + Write_Char (']'); + + -- End artifactChange + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Artifact_Change; + + ----------------------------- + -- Print_Artifact_Location -- + ----------------------------- + + procedure Print_Artifact_Location (File_Name : String) is + + begin + Write_Str ("""" & "artifactLocation" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("uri", File_Name); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Artifact_Location; + + ----------------------- + -- Print_Replacement -- + ----------------------- + + procedure Print_Replacement (Replacement : Edit_Type) is + -- Span start positions + Fst : constant Source_Ptr := Replacement.Span.First; + Line_Fst : constant Int := Int (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Int := Int (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Replacement.Span.Last; + Line_Lst : constant Int := Int (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Int := Int (Get_Column_Number (Lst)); + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print deletedRegion + + Print_Region (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst, + Name => "deletedRegion"); + + if Replacement.Text /= null then + Write_Char (','); + NL_And_Indent; + + Print_Message (Replacement.Text.all, "insertedContent"); + end if; + + -- End replacement + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Replacement; + + --------------- + -- Print_Fix -- + --------------- + + procedure Print_Fix (Fix : Fix_Type) is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print the message if the location has one + + if Fix.Description /= null then + Print_Message (Fix.Description.all, "description"); + + Write_Char (','); + NL_And_Indent; + end if; + + declare + use Artifact_Change_Lists; + Changes : Artifact_Change_List := Get_Artifact_Changes (Fix); + A : Artifact_Change; + A_It : Iterator := Iterate (Changes); + begin + Write_Str ("""" & "artifactChanges" & """" & ": " & "["); + Begin_Block; + + while Has_Next (A_It) loop + Next (A_It, A); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Print_Artifact_Change (A); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + Destroy (Changes); + end; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Fix; + + ----------------- + -- Print_Fixes -- + ----------------- + + procedure Print_Fixes (Diag : Diagnostic_Type) is + use Diagnostics.Fix_Lists; + F : Fix_Type; + F_It : Iterator; + + First : Boolean := True; + begin + Write_Str ("""" & "fixes" & """" & ": " & "["); + Begin_Block; + + if Present (Diag.Fixes) then + F_It := Iterate (Diag.Fixes); + while Has_Next (F_It) loop + Next (F_It, F); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Fix (F); + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + end Print_Fixes; + + ------------------ + -- Print_Region -- + ------------------ + + procedure Print_Region (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := "region") + is + + begin + Write_Str ("""" & Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_Int_Attribute ("startLine", Start_Line); + Write_Char (','); + NL_And_Indent; + + Write_Int_Attribute ("startColumn", Start_Col); + Write_Char (','); + NL_And_Indent; + + Write_Int_Attribute ("endLine", End_Line); + Write_Char (','); + NL_And_Indent; + + -- Convert the end of the span to the definition of the endColumn + -- for a SARIF region. + + Write_Int_Attribute ("endColumn", End_Col + 1); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Region; + + -------------------- + -- Print_Location -- + -------------------- + + procedure Print_Location (Loc : Labeled_Span_Type; + Msg : String_Ptr) + is + + -- Span start positions + Fst : constant Source_Ptr := Loc.Span.First; + Line_Fst : constant Int := Int (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Int := Int (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Loc.Span.Last; + Line_Lst : constant Int := Int (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Int := Int (Get_Column_Number (Lst)); + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print the message if the location has one + + if Msg /= null then + Print_Message (Msg.all); + + Write_Char (','); + NL_And_Indent; + end if; + + Write_Str ("""" & "physicalLocation" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- Print artifactLocation + + Print_Artifact_Location (To_File_Name (Loc.Span.Ptr)); + + Write_Char (','); + NL_And_Indent; + + -- Print region + + Print_Region (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Location; + + --------------------- + -- Print_Locations -- + --------------------- + + procedure Print_Locations (Diag : Diagnostic_Type) is + use Diagnostics.Labeled_Span_Lists; + Loc : Labeled_Span_Type; + It : Iterator := Iterate (Diag.Locations); + + First : Boolean := True; + begin + Write_Str ("""" & "locations" & """" & ": " & "["); + Begin_Block; + + while Has_Next (It) loop + Next (It, Loc); + + -- Only the primary span is considered as the main location other + -- spans are considered related locations + + if Loc.Is_Primary then + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Location (Loc, Loc.Label); + end if; + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Locations; + + ------------------- + -- Print_Message -- + ------------------- + + procedure Print_Message (Text : String; Name : String := "message") is + + begin + Write_Str ("""" & Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + Write_String_Attribute ("text", Text); + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Message; + + ----------------------------- + -- Print_Related_Locations -- + ----------------------------- + + procedure Print_Related_Locations (Diag : Diagnostic_Type) is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Diag.Locations); + + Sub : Sub_Diagnostic_Type; + Sub_It : Sub_Diagnostic_Lists.Iterator; + + First : Boolean := True; + begin + Write_Str ("""" & "relatedLocations" & """" & ": " & "["); + Begin_Block; + + -- Related locations are the non-primary spans of the diagnostic + + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + -- Non-primary spans are considered related locations + + if not Loc.Is_Primary then + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Location (Loc, Loc.Label); + end if; + end loop; + + -- And the sub-diagnostic locations + + if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then + Sub_It := Sub_Diagnostic_Lists.Iterate (Diag.Sub_Diagnostics); + + while Sub_Diagnostic_Lists.Has_Next (Sub_It) loop + Sub_Diagnostic_Lists.Next (Sub_It, Sub); + + declare + Found : Boolean := False; + + Prim_Loc : Labeled_Span_Type; + begin + if Labeled_Span_Lists.Present (Sub.Locations) then + Loc_It := Labeled_Span_Lists.Iterate (Sub.Locations); + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + -- For sub-diagnostic locations, only the primary span is + -- considered. + + if not Found and then Loc.Is_Primary then + Found := True; + Prim_Loc := Loc; + end if; + end loop; + else + + -- If there are no locations for the sub-diagnostic then use + -- the primary location of the main diagnostic. + + Found := True; + Prim_Loc := Primary_Location (Diag); + end if; + + -- For mapping sub-diagnostics to related locations we have to + -- make some compromises in details. + -- + -- Firstly we only make one entry that is for the primary span + -- of the sub-diagnostic. + -- + -- Secondly this span can also have a label. However this + -- pattern is not advised and by default we include the message + -- of the sub-diagnostic as the message in location node since + -- it should have more information. + + if Found then + if First then + First := False; + else + Write_Char (','); + end if; + NL_And_Indent; + Print_Location (Prim_Loc, Sub.Message); + end if; + end; + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Related_Locations; + + ------------------ + -- Print_Result -- + ------------------ + + procedure Print_Result (Diag : Diagnostic_Type) is + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print ruleId + + Write_String_Attribute ("ruleId", "[" & To_String (Diag.Id) & "]"); + + Write_Char (','); + NL_And_Indent; + + -- Print level + + Write_String_Attribute ("level", Kind_To_String (Diag)); + + Write_Char (','); + NL_And_Indent; + + -- Print message + + Print_Message (Diag.Message.all); + + Write_Char (','); + NL_And_Indent; + + -- Print locations + + Print_Locations (Diag); + + Write_Char (','); + NL_And_Indent; + + -- Print related locations + + Print_Related_Locations (Diag); + + Write_Char (','); + NL_And_Indent; + + -- Print fixes + + Print_Fixes (Diag); + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + end Print_Result; + + ------------------- + -- Print_Results -- + ------------------- + + procedure Print_Results (Diags : Diagnostic_List) is + use Diagnostics.Diagnostics_Lists; + + D : Diagnostic_Type; + + It : Iterator := Iterate (All_Diagnostics); + + First : Boolean := True; + begin + Write_Str ("""" & "results" & """" & ": " & "["); + Begin_Block; + + if Present (Diags) then + while Has_Next (It) loop + Next (It, D); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Result (D); + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + end Print_Results; + + ---------------- + -- Print_Rule -- + ---------------- + + procedure Print_Rule (Diag : Diagnostic_Type) is + Human_Id : constant String_Ptr := Get_Human_Id (Diag); + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("id", "[" & To_String (Diag.Id) & "]"); + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute ("level", Kind_To_String (Diag)); + Write_Char (','); + NL_And_Indent; + + if Human_Id = null then + Write_String_Attribute ("name", "Uncategorized_Diagnostic"); + else + Write_String_Attribute ("name", Human_Id.all); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Rule; + + ----------------- + -- Print_Rules -- + ----------------- + + procedure Print_Rules (Diags : Diagnostic_List) is + use Diagnostics.Diagnostics_Lists; + + R : Diagnostic_Type; + Rules : constant Diagnostic_List := Get_Unique_Rules (Diags); + + It : Iterator := Iterate (Rules); + + First : Boolean := True; + begin + Write_Str ("""" & "rules" & """" & ": " & "["); + Begin_Block; + + while Has_Next (It) loop + Next (It, R); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Rule (R); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Rules; + + ---------------- + -- Print_Tool -- + ---------------- + + procedure Print_Tool (Diags : Diagnostic_List) is + + begin + Write_Str ("""" & "tool" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- -- Attributes of tool + + Write_Str ("""" & "driver" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- Attributes of tool.driver + + Write_String_Attribute ("name", "GNAT"); + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute ("version", Gnat_Version_String); + Write_Char (','); + NL_And_Indent; + + Print_Rules (Diags); + + -- End of tool.driver + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + + -- End of tool + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + end Print_Tool; + + ---------------- + -- Print_Runs -- + ---------------- + + procedure Print_Runs (Diags : Diagnostic_List) is + + begin + Write_Str ("""" & "runs" & """" & ": " & "["); + Begin_Block; + NL_And_Indent; + + -- Runs can consist of multiple "run"-s. However the GNAT SARIF report + -- only has one. + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- A run consists of a tool + + Print_Tool (Diags); + + Write_Char (','); + NL_And_Indent; + + -- A run consists of results + + Print_Results (Diags); + + -- End of run + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + + End_Block; + NL_And_Indent; + + -- End of runs + + Write_Char (']'); + end Print_Runs; + + ------------------------ + -- Print_SARIF_Report -- + ------------------------ + + procedure Print_SARIF_Report (Diags : Diagnostic_List) is + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("version", "2.1.0"); + Write_Char (','); + NL_And_Indent; + + Print_Runs (Diags); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_SARIF_Report; + +end Diagnostics.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-sarif_emitter.ads b/gcc/ada/diagnostics-sarif_emitter.ads new file mode 100644 index 00000000000..3d9bbae9cea --- /dev/null +++ b/gcc/ada/diagnostics-sarif_emitter.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . S A R I F _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.SARIF_Emitter is + + procedure Print_SARIF_Report (Diags : Diagnostic_List); +end Diagnostics.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-switch_repository.adb b/gcc/ada/diagnostics-switch_repository.adb new file mode 100644 index 00000000000..d60990192f2 --- /dev/null +++ b/gcc/ada/diagnostics-switch_repository.adb @@ -0,0 +1,688 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Output; use Output; +package body Diagnostics.Switch_Repository is + + Switches : constant array (Switch_Id) + of Switch_Type := + (No_Switch_Id => + (others => <>), + gnatwb => + (Human_Id => new String'("Warn_On_Bad_Fixed_Value"), + Status => Active, + Short_Name => new String'("gnatwb"), + Description => null, + Documentation_Url => null), + gnatwc => + (Human_Id => new String'("Constant_Condition_Warnings"), + Status => Active, + Short_Name => new String'("gnatwc"), + Description => null, + Documentation_Url => null), + gnatwd => + -- TODO: is this a subcheck of general gnatwu? + (Human_Id => new String'("Warn_On_Dereference"), + Status => Active, + Short_Name => new String'("gnatwd"), + Description => null, + Documentation_Url => null), + gnatwf => + (Human_Id => new String'("Check_Unreferenced_Formals"), + Status => Active, + Short_Name => new String'("gnatwf"), + Description => null, + Documentation_Url => null), + gnatwg => + (Human_Id => new String'("Warn_On_Unrecognized_Pragma"), + Status => Active, + Short_Name => new String'("gnatwg"), + Description => null, + Documentation_Url => null), + gnatwh => + (Human_Id => new String'("Warn_On_Hiding"), + Status => Active, + Short_Name => new String'("gnatwh"), + Description => null, + Documentation_Url => null), + gnatwi => + (Human_Id => new String'("Implementation_Unit_Warnings"), + Status => Active, + Short_Name => new String'("gnatwi"), + Description => null, + Documentation_Url => null), + gnatwj => + (Human_Id => new String'("Warn_On_Obsolescent_Feature"), + Status => Active, + Short_Name => new String'("gnatwj"), + Description => null, + Documentation_Url => null), + gnatwk => + (Human_Id => new String'("Warn_On_Constant"), + Status => Active, + Short_Name => new String'("gnatwk"), + Description => null, + Documentation_Url => null), + gnatwl => + (Human_Id => new String'("Elab_Warnings"), + Status => Active, + Short_Name => new String'("gnatwl"), + Description => null, + Documentation_Url => null), + gnatwm => + (Human_Id => new String'("Warn_On_Modified_Unread"), + Status => Active, + Short_Name => new String'("gnatwm"), + Description => null, + Documentation_Url => null), + gnatwo => + (Human_Id => new String'("Address_Clause_Overlay_Warnings"), + Status => Active, + Short_Name => new String'("gnatwo"), + Description => null, + Documentation_Url => null), + gnatwp => + (Human_Id => new String'("Ineffective_Inline_Warnings"), + Status => Active, + Short_Name => new String'("gnatwp"), + Description => null, + Documentation_Url => null), + gnatwq => + (Human_Id => new String'("Warn_On_Questionable_Missing_Parens"), + Status => Active, + Short_Name => new String'("gnatwq"), + Description => null, + Documentation_Url => null), + gnatwr => + (Human_Id => new String'("Warn_On_Redundant_Constructs"), + Status => Active, + Short_Name => new String'("gnatwr"), + Description => null, + Documentation_Url => null), + gnatwt => + (Human_Id => new String'("Warn_On_Deleted_Code"), + Status => Active, + Short_Name => new String'("gnatwt"), + Description => null, + Documentation_Url => null), + gnatwu => + (Human_Id => new String'("Warn_On_Unused_Entities"), + Status => Active, + Short_Name => new String'("gnatwu"), + Description => null, + Documentation_Url => null), + gnatwv => + (Human_Id => new String'("Warn_On_No_Value_Assigned"), + Status => Active, + Short_Name => new String'("gnatwv"), + Description => null, + Documentation_Url => null), + gnatww => + (Human_Id => new String'("Warn_On_Assumed_Low_Bound"), + Status => Active, + Short_Name => new String'("gnatww"), + Description => null, + Documentation_Url => null), + gnatwx => + (Human_Id => new String'("Warn_On_Export_Import"), + Status => Active, + Short_Name => new String'("gnatwx"), + Description => null, + Documentation_Url => null), + gnatwy => + (Human_Id => new String'("Warn_On_Ada_Compatibility_Issues"), + Status => Active, + Short_Name => new String'("gnatwy"), + Description => null, + Documentation_Url => null), + gnatwz => + (Human_Id => new String'("Warn_On_Unchecked_Conversion"), + Status => Active, + Short_Name => new String'("gnatwz"), + Description => null, + Documentation_Url => null), + gnatw_dot_a => + (Human_Id => new String'("Warn_On_Assertion_Failure"), + Status => Active, + Short_Name => new String'("gnatw.a"), + Description => null, + Documentation_Url => null), + gnatw_dot_b => + (Human_Id => new String'("Warn_On_Biased_Representation"), + Status => Active, + Short_Name => new String'("gnatw.b"), + Description => null, + Documentation_Url => null), + gnatw_dot_c => + (Human_Id => new String'("Warn_On_Unrepped_Components"), + Status => Active, + Short_Name => new String'("gnatw.c"), + Description => null, + Documentation_Url => null), + gnatw_dot_f => + (Human_Id => new String'("Warn_On_Elab_Access"), + Status => Active, + Short_Name => new String'("gnatw.f"), + Description => null, + Documentation_Url => null), + gnatw_dot_h => + (Human_Id => new String'("Warn_On_Record_Holes"), + Status => Active, + Short_Name => new String'("gnatw.h"), + Description => null, + Documentation_Url => null), + gnatw_dot_i => + (Human_Id => new String'("Warn_On_Overlap"), + Status => Active, + Short_Name => new String'("gnatw.i"), + Description => null, + Documentation_Url => null), + gnatw_dot_j => + (Human_Id => new String'("Warn_On_Late_Primitives"), + Status => Active, + Short_Name => new String'("gnatw.j"), + Description => null, + Documentation_Url => null), + gnatw_dot_k => + (Human_Id => new String'("Warn_On_Standard_Redefinition"), + Status => Active, + Short_Name => new String'("gnatw.k"), + Description => null, + Documentation_Url => null), + gnatw_dot_l => + (Human_Id => new String'("List_Inherited_Aspects"), + Status => Active, + Short_Name => new String'("gnatw.l"), + Description => null, + Documentation_Url => null), + gnatw_dot_m => + (Human_Id => new String'("Warn_On_Suspicious_Modulus_Value"), + Status => Active, + Short_Name => new String'("gnatw.m"), + Description => null, + Documentation_Url => null), + gnatw_dot_n => + (Human_Id => new String'("Warn_On_Atomic_Synchronization"), + Status => Active, + Short_Name => new String'("gnatw.n"), + Description => null, + Documentation_Url => null), + gnatw_dot_o => + (Human_Id => new String'("Warn_On_All_Unread_Out_Parameters"), + Status => Active, + Short_Name => new String'("gnatw.o"), + Description => null, + Documentation_Url => null), + gnatw_dot_p => + (Human_Id => new String'("Warn_On_Parameter_Order"), + Status => Active, + Short_Name => new String'("gnatw.p"), + Description => null, + Documentation_Url => null), + gnatw_dot_q => + (Human_Id => new String'("Warn_On_Questionable_Layout"), + Status => Active, + Short_Name => new String'("gnatw.q"), + Description => null, + Documentation_Url => null), + gnatw_dot_r => + (Human_Id => new String'("Warn_On_Object_Renames_Function"), + Status => Active, + Short_Name => new String'("gnatw.r"), + Description => null, + Documentation_Url => null), + gnatw_dot_s => + (Human_Id => new String'("Warn_On_Overridden_Size"), + Status => Active, + Short_Name => new String'("gnatw.s"), + Description => null, + Documentation_Url => null), + gnatw_dot_t => + (Human_Id => new String'("Warn_On_Suspicious_Contract"), + Status => Active, + Short_Name => new String'("gnatw.t"), + Description => null, + Documentation_Url => null), + gnatw_dot_u => + (Human_Id => new String'("Warn_On_Unordered_Enumeration_Type"), + Status => Active, + Short_Name => new String'("gnatw.u"), + Description => null, + Documentation_Url => null), + gnatw_dot_v => + (Human_Id => new String'("Warn_On_Reverse_Bit_Order"), + Status => Active, + Short_Name => new String'("gnatw.v"), + Description => null, + Documentation_Url => null), + gnatw_dot_w => + (Human_Id => new String'("Warn_On_Warnings_Off"), + Status => Active, + Short_Name => new String'("gnatw.w"), + Description => null, + Documentation_Url => null), + gnatw_dot_x => + (Human_Id => + new String'("Warn_No_Exception_Propagation_Active"), + Status => Active, + Short_Name => new String'("gnatw.x"), + Description => null, + Documentation_Url => null), + gnatw_dot_y => + (Human_Id => new String'("List_Body_Required_Info"), + Status => Active, + Short_Name => new String'("gnatw.y"), + Description => null, + Documentation_Url => null), + gnatw_dot_z => + (Human_Id => new String'("Warn_On_Size_Alignment"), + Status => Active, + Short_Name => new String'("gnatw.z"), + Description => null, + Documentation_Url => null), + gnatw_underscore_a => + (Human_Id => new String'("Warn_On_Anonymous_Allocators"), + Status => Active, + Short_Name => new String'("gnatw_a"), + Description => null, + Documentation_Url => null), + gnatw_underscore_c => + (Human_Id => new String'("Warn_On_Unknown_Compile_Time_Warning"), + Status => Active, + Short_Name => new String'("gnatw_c"), + Description => null, + Documentation_Url => null), + gnatw_underscore_j => + (Human_Id => new String'("Warn_On_Non_Dispatching_Primitives"), + Status => Active, + Short_Name => new String'("gnatw_j"), + Description => null, + Documentation_Url => null), + gnatw_underscore_l => + (Human_Id => new String'("Warn_On_Inherently_Limited_Types"), + Status => Active, + Short_Name => new String'("gnatw_l"), + Description => null, + Documentation_Url => null), + gnatw_underscore_p => + (Human_Id => new String'("Warn_On_Pedantic_Checks"), + Status => Active, + Short_Name => new String'("gnatw_p"), + Description => null, + Documentation_Url => null), + gnatw_underscore_q => + (Human_Id => new String'("Warn_On_Ignored_Equality"), + Status => Active, + Short_Name => new String'("gnatw_q"), + Description => null, + Documentation_Url => null), + gnatw_underscore_r => + (Human_Id => new String'("Warn_On_Component_Order"), + Status => Active, + Short_Name => new String'("gnatw_r"), + Description => null, + Documentation_Url => null), + gnatw_underscore_s => + (Human_Id => new String'("Warn_On_Ineffective_Predicate_Test"), + Status => Active, + Short_Name => new String'("gnatw_s"), + Description => null, + Documentation_Url => null), + -- NOTE: this flag is usually followed by a number specfifying the + -- indentation level. We encode all of these warnings as -gnaty0 + -- irregardless of the actual numeric value. + gnaty => + (Human_Id => new String'("Style_Check_Indentation_Level"), + Status => Active, + Short_Name => new String'("gnaty0"), + Description => null, + Documentation_Url => null), + gnatya => + (Human_Id => new String'("Style_Check_Attribute_Casing"), + Status => Active, + Short_Name => new String'("gnatya"), + Description => null, + Documentation_Url => null), + gnatyaa => + (Human_Id => new String'("Address_Clause_Overlay_Warnings"), + Status => Active, + Short_Name => new String'("gnatyA"), + Description => null, + Documentation_Url => null), + gnatyb => + (Human_Id => new String'("Style_Check_Blanks_At_End"), + Status => Active, + Short_Name => new String'("gnatyb"), + Description => null, + Documentation_Url => null), + gnatybb => + -- NOTE: in live documentation it is called "Check Boolean operators" + (Human_Id => new String'("Style_Check_Boolean_And_Or"), + Status => Active, + Short_Name => new String'("gnatyB"), + Description => null, + Documentation_Url => null), + gnatyc => + (Human_Id => new String'("Style_Check_Comments_Double_Space"), + Status => Active, + Short_Name => new String'("gnatyc"), + Description => null, + Documentation_Url => null), + gnatycc => + (Human_Id => new String'("Style_Check_Comments_Single_Space"), + Status => Active, + Short_Name => new String'("gnatyC"), + Description => null, + Documentation_Url => null), + gnatyd => + (Human_Id => new String'("Style_Check_DOS_Line_Terminator"), + Status => Active, + Short_Name => new String'("gnatyd"), + Description => null, + Documentation_Url => null), + gnatydd => + (Human_Id => new String'("Style_Check_Mixed_Case_Decls"), + Status => Active, + Short_Name => new String'("gnatyD"), + Description => null, + Documentation_Url => null), + gnatye => + (Human_Id => new String'("Style_Check_End_Labels"), + Status => Active, + Short_Name => new String'("gnatye"), + Description => null, + Documentation_Url => null), + gnatyf => + (Human_Id => new String'("Style_Check_Form_Feeds"), + Status => Active, + Short_Name => new String'("gnatyf"), + Description => null, + Documentation_Url => null), + gnatyh => + (Human_Id => new String'("Style_Check_Horizontal_Tabs"), + Status => Active, + Short_Name => new String'("gnatyh"), + Description => null, + Documentation_Url => null), + gnatyi => + (Human_Id => new String'("Style_Check_If_Then_Layout"), + Status => Active, + Short_Name => new String'("gnatyi"), + Description => null, + Documentation_Url => null), + gnatyii => + (Human_Id => new String'("Style_Check_Mode_In"), + Status => Active, + Short_Name => new String'("gnatyI"), + Description => null, + Documentation_Url => null), + gnatyk => + (Human_Id => new String'("Style_Check_Keyword_Casing"), + Status => Active, + Short_Name => new String'("gnatyk"), + Description => null, + Documentation_Url => null), + gnatyl => + (Human_Id => new String'("Style_Check_Layout"), + Status => Active, + Short_Name => new String'("gnatyl"), + Description => null, + Documentation_Url => null), + gnatyll => + (Human_Id => new String'("Style_Check_Max_Nesting_Level"), + Status => Active, + Short_Name => new String'("gnatyL"), + Description => null, + Documentation_Url => null), + gnatym => + (Human_Id => new String'("Style_Check_Max_Line_Length"), + Status => Active, + Short_Name => new String'("gnatym"), + Description => null, + Documentation_Url => null), + gnatymm => + -- TODO: May contain line length + (Human_Id => new String'("Style_Check_Max_Line_Length"), + Status => Active, + Short_Name => new String'("gnatyM"), + Description => null, + Documentation_Url => null), + gnatyn => + (Human_Id => new String'("Style_Check_Standard"), + Status => Active, + Short_Name => new String'("gnatyn"), + Description => null, + Documentation_Url => null), + gnatyo => + (Human_Id => new String'("Style_Check_Order_Subprograms"), + Status => Active, + Short_Name => new String'("gnatyo"), + Description => null, + Documentation_Url => null), + gnatyoo => + (Human_Id => new String'("Style_Check_Missing_Overriding"), + Status => Active, + Short_Name => new String'("gnatyO"), + Description => null, + Documentation_Url => null), + gnatyp => + (Human_Id => new String'("Style_Check_Pragma_Casing"), + Status => Active, + Short_Name => new String'("gnatyp"), + Description => null, + Documentation_Url => null), + gnatyr => + (Human_Id => new String'("Style_Check_References"), + Status => Active, + Short_Name => new String'("gnatyr"), + Description => null, + Documentation_Url => null), + gnatys => + (Human_Id => new String'("Style_Check_Specs"), + Status => Active, + Short_Name => new String'("gnatys"), + Description => null, + Documentation_Url => null), + gnatyss => + (Human_Id => new String'("Style_Check_Separate_Stmt_Lines"), + Status => Active, + Short_Name => new String'("gnatyS"), + Description => null, + Documentation_Url => null), + gnatytt => + (Human_Id => new String'("Style_Check_Tokens"), + Status => Active, + Short_Name => new String'("gnatyt"), + Description => null, + Documentation_Url => null), + gnatyu => + (Human_Id => new String'("Style_Check_Blank_Lines"), + Status => Active, + Short_Name => new String'("gnatyu"), + Description => null, + Documentation_Url => null), + gnatyx => + (Human_Id => new String'("Style_Check_Xtra_Parens"), + Status => Active, + Short_Name => new String'("gnatyx"), + Description => null, + Documentation_Url => null), + gnatyz => + (Human_Id => new String'("Style_Check_Xtra_Parens_Precedence"), + Status => Active, + Short_Name => new String'("gnatyz"), + Description => null, + Documentation_Url => null), + gnatel => + (Human_Id => new String'("Display_Elaboration_Messages"), + Status => Active, + Short_Name => new String'("gnatel"), + Description => null, + Documentation_Url => null) + ); + + ---------------- + -- Get_Switch -- + ---------------- + + function Get_Switch (Id : Switch_Id) return Switch_Type is + + begin + return Switches (Id); + end Get_Switch; + + function Get_Switch (Diag : Diagnostic_Type) return Switch_Type is + + begin + return Get_Switch (Diag.Switch); + end Get_Switch; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (Name : String) return Switch_Id is + Trimmed_Name : constant String := + (if Name (Name'Last) = ' ' then Name (Name'First .. Name'Last - 1) + else Name); + begin + for I in Active_Switch_Id loop + if Switches (I).Short_Name.all = Trimmed_Name then + return I; + end if; + end loop; + + return No_Switch_Id; + end Get_Switch_Id; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is + + begin + if E.Warn_Chr = "$ " then + return Get_Switch_Id ("gnatel"); + elsif E.Warn or E.Info then + return Get_Switch_Id ("gnatw" & E.Warn_Chr); + elsif E.Style then + return Get_Switch_Id ("gnaty" & E.Warn_Chr); + else + return No_Switch_Id; + end if; + end Get_Switch_Id; + + ----------------------------- + -- Print_Switch_Repository -- + ----------------------------- + + procedure Print_Switch_Repository is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & "Switches" & """" & ": " & "["); + Begin_Block; + + -- Avoid printing the first switch, which is a placeholder + + for I in Active_Switch_Id loop + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + if Switches (I).Human_Id /= null then + Write_String_Attribute ("Human_Id", Switches (I).Human_Id.all); + else + Write_String_Attribute ("Human_Id", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Short_Name /= null then + Write_String_Attribute ("Short_Name", Switches (I).Short_Name.all); + else + Write_String_Attribute ("Short_Name", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Status = Active then + Write_String_Attribute ("Status", "Active"); + else + Write_String_Attribute ("Status", "Deprecated"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Description /= null then + Write_String_Attribute ("Description", + Switches (I).Description.all); + else + Write_String_Attribute ("Description", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Description /= null then + Write_String_Attribute ("Documentation_Url", + Switches (I).Description.all); + else + Write_String_Attribute ("Documentation_Url", "null"); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_Switch_Repository; + +end Diagnostics.Switch_Repository; diff --git a/gcc/ada/diagnostics-switch_repository.ads b/gcc/ada/diagnostics-switch_repository.ads new file mode 100644 index 00000000000..5bd2d519bb3 --- /dev/null +++ b/gcc/ada/diagnostics-switch_repository.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Erroutc; use Erroutc; + +package Diagnostics.Switch_Repository is + + function Get_Switch (Id : Switch_Id) return Switch_Type; + + function Get_Switch (Diag : Diagnostic_Type) return Switch_Type; + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id; + + function Get_Switch_Id (Name : String) return Switch_Id; + + procedure Print_Switch_Repository; + +end Diagnostics.Switch_Repository; diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb new file mode 100644 index 00000000000..3203e636290 --- /dev/null +++ b/gcc/ada/diagnostics-utils.adb @@ -0,0 +1,358 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . U T I L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Errout; use Errout; +with Erroutc; use Erroutc; +with Namet; use Namet; +with Opt; use Opt; +with Sinput; use Sinput; +with Sinfo.Nodes; use Sinfo.Nodes; +with Warnsw; use Warnsw; + +package body Diagnostics.Utils is + + ------------------ + -- Get_Human_Id -- + ------------------ + + function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is + begin + if D.Switch = No_Switch_Id then + return Diagnostic_Entries (D.Id).Human_Id; + else + return Get_Switch (D).Human_Id; + end if; + end Get_Human_Id; + + ------------------ + -- To_File_Name -- + ------------------ + + function To_File_Name (Sptr : Source_Ptr) return String is + Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); + Ref_Name : constant File_Name_Type := + (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) + else Reference_Name (Sfile)); + + begin + return Get_Name_String (Ref_Name); + end To_File_Name; + + -------------------- + -- Line_To_String -- + -------------------- + + function Line_To_String (Sptr : Source_Ptr) return String is + Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Line)); + + begin + return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Line_To_String; + + ---------------------- + -- Column_To_String -- + ---------------------- + + function Column_To_String (Sptr : Source_Ptr) return String is + Col : constant Column_Number := Get_Column_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Col)); + + begin + return + (if Col < 10 then "0" else "") + & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Column_To_String; + + --------------- + -- To_String -- + --------------- + + function To_String (Sptr : Source_Ptr) return String is + begin + return + To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" + & Column_To_String (Sptr); + end To_String; + + -------------------- + -- Sloc_To_String -- + -------------------- + + function Sloc_To_String + (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String + is + + begin + return Sloc_To_String (Sloc (N), Ref); + end Sloc_To_String; + + -------------------- + -- Sloc_To_String -- + -------------------- + + function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String + is + + begin + if Sptr = No_Location then + return "at unknown location"; + + elsif Sptr = System_Location then + return "in package System"; + + elsif Sptr = Standard_Location then + return "in package Standard"; + + elsif Sptr = Standard_ASCII_Location then + return "in package Standard.ASCII"; + + else + if Full_File_Name (Get_Source_File_Index (Sptr)) + /= Full_File_Name (Get_Source_File_Index (Ref)) + then + return "at " & To_String (Sptr); + else + return "at line " & Line_To_String (Sptr); + end if; + end if; + end Sloc_To_String; + + ------------------ + -- To_Full_Span -- + ------------------ + + function To_Full_Span (N : Node_Id) return Source_Span + is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (N, Fst, Lst); + return To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst)); + end To_Full_Span; + + --------------- + -- To_String -- + --------------- + + function To_String (Id : Diagnostic_Id) return String is + begin + if Id = No_Diagnostic_Id then + return "GNAT0000"; + else + return Id'Img; + end if; + end To_String; + + ------------- + -- To_Name -- + ------------- + + function To_Name (E : Entity_Id) return String is + begin + -- The name of the node operator "&" has many special cases. Reuse the + -- node to name conversion implementation from the errout package for + -- now. + + Error_Msg_Node_1 := E; + Set_Msg_Text ("&", Sloc (E)); + + return Msg_Buffer (1 .. Msglen); + end To_Name; + + ------------------ + -- To_Type_Name -- + ------------------ + + function To_Type_Name (E : Entity_Id) return String is + begin + Error_Msg_Node_1 := E; + Set_Msg_Text ("}", Sloc (E)); + + return Msg_Buffer (1 .. Msglen); + end To_Type_Name; + + -------------------- + -- Kind_To_String -- + -------------------- + + function Kind_To_String + (D : Sub_Diagnostic_Type; + Parent : Diagnostic_Type) return String + is + (case D.Kind is + when Continuation => Kind_To_String (Parent), + when Help => "help", + when Note => "note", + when Suggestion => "suggestion"); + + -------------------- + -- Kind_To_String -- + -------------------- + + function Kind_To_String (D : Diagnostic_Type) return String is + (if D.Warn_Err then "error" + else + (case D.Kind is + when Diagnostics.Error => "error", + when Warning | Restriction_Warning | Default_Warning | + Tagless_Warning => "warning", + when Style => "style", + when Info | Info_Warning => "info")); + + ------------------------------ + -- Get_Primary_Labeled_Span -- + ------------------------------ + + function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) + return Labeled_Span_Type + is + use Labeled_Span_Lists; + + S : Labeled_Span_Type; + It : Iterator; + begin + if Present (Spans) then + It := Iterate (Spans); + while Has_Next (It) loop + Next (It, S); + if S.Is_Primary then + return S; + end if; + end loop; + end if; + + return No_Labeled_Span; + end Get_Primary_Labeled_Span; + + -------------------- + -- Get_Doc_Switch -- + -------------------- + + function Get_Doc_Switch (Diag : Diagnostic_Type) return String is + begin + if Warning_Doc_Switch + and then Diag.Kind in Default_Warning + | Info + | Info_Warning + | Restriction_Warning + | Style + | Warning + then + if Diag.Switch = No_Switch_Id then + if Diag.Kind = Restriction_Warning then + return "[restriction warning]"; + + -- Info messages can have a switch tag but they should not have + -- a default switch tag. + + elsif Diag.Kind /= Info then + + -- For Default_Warning and Info_Warning + + return "[enabled by default]"; + end if; + else + declare + S : constant Switch_Type := Get_Switch (Diag); + begin + return "[-" & S.Short_Name.all & "]"; + end; + end if; + end if; + + return ""; + end Get_Doc_Switch; + + -------------------- + -- Appears_Before -- + -------------------- + + function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is + + begin + return Appears_Before (Primary_Location (D1).Span.Ptr, + Primary_Location (D2).Span.Ptr); + end Appears_Before; + + -------------------- + -- Appears_Before -- + -------------------- + + function Appears_Before (P1, P2 : Source_Ptr) return Boolean is + + begin + if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then + if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then + return Get_Column_Number (P1) < Get_Column_Number (P2); + else + return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2); + end if; + else + return Get_Source_File_Index (P1) < Get_Source_File_Index (P2); + end if; + end Appears_Before; + + ------------------------------ + -- Insert_Based_On_Location -- + ------------------------------ + + procedure Insert_Based_On_Location + (List : Diagnostic_List; + Diagnostic : Diagnostic_Type) + is + use Diagnostics_Lists; + + It : Iterator := Iterate (List); + D : Diagnostic_Type; + begin + -- This is the common scenario where the error is reported at the + -- natural order the tree is processed. This saves a lot of time when + -- looking for the correct position in the list when there are a lot of + -- diagnostics. + + if Present (List) and then + not Is_Empty (List) and then + Appears_Before (Last (List), Diagnostic) + then + Append (List, Diagnostic); + else + while Has_Next (It) loop + Next (It, D); + + if Appears_Before (Diagnostic, D) then + Insert_Before (List, D, Diagnostic); + return; + end if; + end loop; + + Append (List, Diagnostic); + end if; + end Insert_Based_On_Location; + +end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics-utils.ads b/gcc/ada/diagnostics-utils.ads new file mode 100644 index 00000000000..caf01abc3cb --- /dev/null +++ b/gcc/ada/diagnostics-utils.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . U T I L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Utils is + + function Get_Human_Id (D : Diagnostic_Type) return String_Ptr; + + function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String; + -- Convert the source pointer to a string and prefix it with the correct + -- preposition. + -- + -- * If the location is in one of the standard locations, + -- then it yields "in package ". The explicit standard + -- locations are: + -- * System + -- * Standard + -- * Standard.ASCII + -- * if the location is missing the the sloc yields "at unknown location" + -- * if the location is in the same file as the current file, + -- then it yields "at line ". + -- * Otherwise sloc yields "at ::" + + function Sloc_To_String (N : Node_Or_Entity_Id; + Ref : Source_Ptr) + return String; + -- Converts the Sloc of the node or entity to a Sloc string. + + function To_String (Sptr : Source_Ptr) return String; + -- Convert the source pointer to a string of the form: "file:line:column" + + function To_File_Name (Sptr : Source_Ptr) return String; + -- Converts the file name of the Sptr to a string. + + function Line_To_String (Sptr : Source_Ptr) return String; + -- Converts the logical line number of the Sptr to a string. + + function Column_To_String (Sptr : Source_Ptr) return String; + -- Converts the column number of the Sptr to a string. Column values less + -- than 10 are prefixed with a 0. + + function To_Full_Span (N : Node_Id) return Source_Span; + + function To_String (Id : Diagnostic_Id) return String; + -- Convert the diagnostic ID to a 4 character string padded with 0-s. + + function To_Name (E : Entity_Id) return String; + + function To_Type_Name (E : Entity_Id) return String; + + function Kind_To_String (D : Diagnostic_Type) return String; + + function Kind_To_String + (D : Sub_Diagnostic_Type; + Parent : Diagnostic_Type) return String; + + function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) + return Labeled_Span_Type; + + function Get_Doc_Switch (Diag : Diagnostic_Type) return String; + + function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean; + + function Appears_Before (P1, P2 : Source_Ptr) return Boolean; + + procedure Insert_Based_On_Location + (List : Diagnostic_List; + Diagnostic : Diagnostic_Type); + +end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb new file mode 100644 index 00000000000..8acc915b915 --- /dev/null +++ b/gcc/ada/diagnostics.adb @@ -0,0 +1,542 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Diagnostics.Brief_Emitter; +with Diagnostics.Pretty_Emitter; +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.Utils; use Diagnostics.Utils; +with Lib; use Lib; +with Opt; use Opt; +with Sinput; use Sinput; +with Warnsw; + +package body Diagnostics is + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Labeled_Span_Type) is + begin + Free (Elem.Label); + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Sub_Diagnostic_Type) is + begin + Free (Elem.Message); + if Labeled_Span_Lists.Present (Elem.Locations) then + Labeled_Span_Lists.Destroy (Elem.Locations); + end if; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Edit_Type) is + begin + Free (Elem.Text); + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Fix_Type) is + begin + Free (Elem.Description); + if Edit_Lists.Present (Elem.Edits) then + Edit_Lists.Destroy (Elem.Edits); + end if; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Diagnostic_Type) is + begin + Free (Elem.Message); + if Labeled_Span_Lists.Present (Elem.Locations) then + Labeled_Span_Lists.Destroy (Elem.Locations); + end if; + if Sub_Diagnostic_Lists.Present (Elem.Sub_Diagnostics) then + Sub_Diagnostic_Lists.Destroy (Elem.Sub_Diagnostics); + end if; + if Fix_Lists.Present (Elem.Fixes) then + Fix_Lists.Destroy (Elem.Fixes); + end if; + end Destroy; + + ------------------ + -- Add_Location -- + ------------------ + + procedure Add_Location + (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type) + is + use Labeled_Span_Lists; + begin + if not Present (Diagnostic.Locations) then + Diagnostic.Locations := Create; + end if; + + Append (Diagnostic.Locations, Location); + end Add_Location; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location + (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type + is + use Labeled_Span_Lists; + Loc : Labeled_Span_Type; + + It : Iterator := Iterate (Diagnostic.Locations); + begin + while Has_Next (It) loop + Next (It, Loc); + if Loc.Is_Primary then + return Loc; + end if; + end loop; + + return (others => <>); + end Primary_Location; + + ------------------ + -- Add_Location -- + ------------------ + + procedure Add_Location + (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type) + is + use Labeled_Span_Lists; + begin + if not Present (Diagnostic.Locations) then + Diagnostic.Locations := Create; + end if; + + Append (Diagnostic.Locations, Location); + end Add_Location; + + ------------------------ + -- Add_Sub_Diagnostic -- + ------------------------ + + procedure Add_Sub_Diagnostic + (Diagnostic : in out Diagnostic_Type; + Sub_Diagnostic : Sub_Diagnostic_Type) + is + use Sub_Diagnostic_Lists; + begin + if not Present (Diagnostic.Sub_Diagnostics) then + Diagnostic.Sub_Diagnostics := Create; + end if; + + Append (Diagnostic.Sub_Diagnostics, Sub_Diagnostic); + end Add_Sub_Diagnostic; + + procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type) is + use Edit_Lists; + begin + if not Present (Fix.Edits) then + Fix.Edits := Create; + end if; + + Append (Fix.Edits, Edit); + end Add_Edit; + + ------------- + -- Add_Fix -- + ------------- + + procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type) is + use Fix_Lists; + begin + if not Present (Diagnostic.Fixes) then + Diagnostic.Fixes := Create; + end if; + + Append (Diagnostic.Fixes, Fix); + end Add_Fix; + + ----------------------- + -- Record_Diagnostic -- + ----------------------- + + procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; + Update_Count : Boolean := True) + is + + procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type); + + ----------------------------- + -- Update_Diagnostic_Count -- + ----------------------------- + + procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is + + begin + if Diagnostic.Kind = Error then + Total_Errors_Detected := Total_Errors_Detected + 1; + + if Diagnostic.Serious then + Serious_Errors_Detected := Serious_Errors_Detected + 1; + end if; + elsif Diagnostic.Kind in Warning | Style then + Warnings_Detected := Warnings_Detected + 1; + + if Diagnostic.Warn_Err then + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + end if; + elsif Diagnostic.Kind in Info then + Info_Messages := Info_Messages + 1; + end if; + end Update_Diagnostic_Count; + + procedure Handle_Serious_Error; + -- Internal procedure to do all error message handling for a serious + -- error message, other than bumping the error counts and arranging + -- for the message to be output. + + procedure Handle_Serious_Error is + begin + -- Turn off code generation if not done already + + if Operating_Mode = Generate_Code then + Operating_Mode := Check_Semantics; + Expander_Active := False; + end if; + + -- Set the fatal error flag in the unit table unless we are in + -- Try_Semantics mode (in which case we set ignored mode if not + -- currently set. This stops the semantics from being performed + -- if we find a serious error. This is skipped if we are currently + -- dealing with the configuration pragma file. + + if Current_Source_Unit /= No_Unit then + declare + U : constant Unit_Number_Type := + Get_Source_Unit + (Primary_Location (Diagnostic).Span.Ptr); + begin + if Try_Semantics then + if Fatal_Error (U) = None then + Set_Fatal_Error (U, Error_Ignored); + end if; + else + Set_Fatal_Error (U, Error_Detected); + end if; + end; + end if; + + -- Disable warnings on unused use clauses and the like. Otherwise, an + -- error might hide a reference to an entity in a used package, so + -- after fixing the error, the use clause no longer looks like it was + -- unused. + + Warnsw.Check_Unreferenced := False; + Warnsw.Check_Unreferenced_Formals := False; + end Handle_Serious_Error; + begin + Insert_Based_On_Location (All_Diagnostics, Diagnostic); + + if Update_Count then + Update_Diagnostic_Count (Diagnostic); + end if; + + if Diagnostic.Kind = Error and then Diagnostic.Serious then + Handle_Serious_Error; + end if; + end Record_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diagnostic : Diagnostic_Type) is + + begin + if Debug_Flag_FF then + Diagnostics.Pretty_Emitter.Print_Diagnostic (Diagnostic); + else + Diagnostics.Brief_Emitter.Print_Diagnostic (Diagnostic); + end if; + end Print_Diagnostic; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location + (Diagnostic : Diagnostic_Type) return Labeled_Span_Type + is + begin + return Get_Primary_Labeled_Span (Diagnostic.Locations); + end Primary_Location; + + --------------------- + -- Make_Diagnostic -- + --------------------- + + function Make_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + return Diagnostic_Type + is + D : Diagnostic_Type; + begin + D.Message := new String'(Msg); + D.Id := Id; + D.Kind := Kind; + + if Id /= No_Diagnostic_Id then + pragma Assert (Switch = Diagnostic_Entries (Id).Switch, + "Provided switch must be the same as in the registry"); + end if; + D.Switch := Switch; + + pragma Assert (Location.Is_Primary, "Main location must be primary"); + Add_Location (D, Location); + + for I in Spans'Range loop + Add_Location (D, Spans (I)); + end loop; + + for I in Sub_Diags'Range loop + Add_Sub_Diagnostic (D, Sub_Diags (I)); + end loop; + + for I in Fixes'Range loop + Add_Fix (D, Fixes (I)); + end loop; + + return D; + end Make_Diagnostic; + + ----------------------- + -- Record_Diagnostic -- + ----------------------- + + procedure Record_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + is + + begin + Record_Diagnostic + (Make_Diagnostic + (Msg => Msg, + Location => Location, + Id => Id, + Kind => Kind, + Switch => Switch, + Spans => Spans, + Sub_Diags => Sub_Diags, + Fixes => Fixes)); + end Record_Diagnostic; + + ------------------ + -- Labeled_Span -- + ------------------ + + function Labeled_Span (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type + is + L : Labeled_Span_Type; + begin + L.Span := Span; + if Label /= "" then + L.Label := new String'(Label); + end if; + L.Is_Primary := Is_Primary; + L.Is_Region := Is_Region; + + return L; + end Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type + is begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => True); + end Primary_Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type + is + begin + return Primary_Labeled_Span (To_Full_Span (N), Label); + end Primary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span + (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type + is + begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => False); + end Secondary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type + is + begin + return Secondary_Labeled_Span (To_Full_Span (N), Label); + end Secondary_Labeled_Span; + + -------------- + -- Sub_Diag -- + -------------- + + function Sub_Diag (Msg : String; + Kind : Sub_Diagnostic_Kind := + Diagnostics.Continuation; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + S : Sub_Diagnostic_Type; + begin + S.Message := new String'(Msg); + S.Kind := Kind; + + for I in Locations'Range loop + Add_Location (S, Locations (I)); + end loop; + + return S; + end Sub_Diag; + + ------------------ + -- Continuation -- + ------------------ + + function Continuation (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Continuation, Locations); + end Continuation; + + ---------- + -- Help -- + ---------- + + function Help (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Help, Locations); + end Help; + + ---------------- + -- Suggestion -- + ---------------- + + function Suggestion (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Suggestion, Locations); + end Suggestion; + + --------- + -- Fix -- + --------- + + function Fix + (Description : String; + Edits : Edit_Array; + Applicability : Applicability_Type := Unspecified) return Fix_Type + is + F : Fix_Type; + begin + F.Description := new String'(Description); + + for I in Edits'Range loop + Add_Edit (F, Edits (I)); + end loop; + + F.Applicability := Applicability; + + return F; + end Fix; + + ---------- + -- Edit -- + ---------- + + function Edit (Text : String; Span : Source_Span) return Edit_Type is + + begin + return (Text => new String'(Text), Span => Span); + end Edit; + +end Diagnostics; diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads new file mode 100644 index 00000000000..18afb1c21ba --- /dev/null +++ b/gcc/ada/diagnostics.ads @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +with GNAT.Lists; use GNAT.Lists; + +package Diagnostics is + + type Diagnostic_Id is + (No_Diagnostic_Id, + GNAT0001, + GNAT0002, + GNAT0003, + GNAT0004, + GNAT0005, + GNAT0006, + GNAT0007, + GNAT0008, + GNAT0009, + GNAT0010); + + -- Labeled_Span_Type represents a span of source code that is associated + -- with a textual label. Primary spans indicate the primary location of the + -- diagnostic. Non-primary spans are used to indicate secondary locations. + -- + -- Spans can contain labels that are used to annotate the highlighted span. + -- Usually, the label is a short and concise message that provide + -- additional allthough non-critical information about the span. This is + -- an important since labels are not printed in the brief output and are + -- only present in the pretty and structural outputs. That is an important + -- distintion when choosing between a label and a sub-diagnostic. + type Labeled_Span_Type is record + Label : String_Ptr := null; + -- Text associated with the span + + Span : Source_Span := (others => No_Location); + -- Textual region in the source code + + Is_Primary : Boolean := True; + -- Primary spans are used to indicate the primary location of the + -- diagnostic. Typically there should just be one primary span per + -- diagnostic. + -- Non-primary spans are used to indicate secondary locations and + -- typically are formatted in a different way or omitted in some + -- contexts. + + Is_Region : Boolean := False; + -- Regional spans are multiline spans that have a unique way of being + -- displayed in the pretty output. + end record; + + No_Labeled_Span : constant Labeled_Span_Type := (others => <>); + + procedure Destroy (Elem : in out Labeled_Span_Type); + pragma Inline (Destroy); + + package Labeled_Span_Lists is new Doubly_Linked_Lists + (Element_Type => Labeled_Span_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List; + + type Sub_Diagnostic_Kind is + (Continuation, + Help, + Note, + Suggestion); + + -- Sub_Diagnostic_Type represents a sub-diagnostic message that is meant + -- to provide additional information about the primary diagnostic message. + -- + -- Sub-diagnostics are usually constructed with a full sentence as the + -- message and provide important context to the main diagnostic message or + -- some concrete action to the user. + -- + -- This is different from the labels of labeled spans which are meant to be + -- short and concise and are mostly there to annotate the higlighted span. + + type Sub_Diagnostic_Type is record + Kind : Sub_Diagnostic_Kind; + + Message : String_Ptr; + + Locations : Labeled_Span_List; + end record; + + procedure Add_Location + (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type); + + function Primary_Location + (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type; + + procedure Destroy (Elem : in out Sub_Diagnostic_Type); + pragma Inline (Destroy); + + package Sub_Diagnostic_Lists is new Doubly_Linked_Lists + (Element_Type => Sub_Diagnostic_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Sub_Diagnostic_List is Sub_Diagnostic_Lists.Doubly_Linked_List; + + -- An Edit_Type represents a textual edit that is associated with a Fix. + type Edit_Type is record + Span : Source_Span; + -- Region of the file to be removed + + Text : String_Ptr; + -- Text to be inserted at the start location of the span + end record; + + procedure Destroy (Elem : in out Edit_Type); + pragma Inline (Destroy); + + package Edit_Lists is new Doubly_Linked_Lists + (Element_Type => Edit_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Edit_List is Edit_Lists.Doubly_Linked_List; + + -- Type Applicability_Type will indicate the state of the resulting code + -- after applying a fix. + -- * Option Has_Placeholders indicates that the fix contains placeholders + -- that the user would need to fill. + -- * Option Legal indicates that applying the fix will result in legal Ada + -- code. + -- * Option Possibly_Illegal indicates that applying the fix will result in + -- possibly legal, but also possibly illegal Ada code. + type Applicability_Type is + (Has_Placeholders, + Legal, + Possibly_Illegal, + Unspecified); + + type Fix_Type is record + Description : String_Ptr := null; + -- Message describing the fix that will be displayed to the user. + + Applicability : Applicability_Type := Unspecified; + + Edits : Edit_List; + -- File changes for the fix. + end record; + + procedure Destroy (Elem : in out Fix_Type); + pragma Inline (Destroy); + + package Fix_Lists is new Doubly_Linked_Lists + (Element_Type => Fix_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Fix_List is Fix_Lists.Doubly_Linked_List; + + procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type); + + type Status_Type is + (Active, + Deprecated); + + type Switch_Id is ( + No_Switch_Id, + gnatwb, + gnatwc, + gnatwd, + gnatwf, + gnatwg, + gnatwh, + gnatwi, + gnatwj, + gnatwk, + gnatwl, + gnatwm, + gnatwo, + gnatwp, + gnatwq, + gnatwr, + gnatwt, + gnatwu, + gnatwv, + gnatww, + gnatwx, + gnatwy, + gnatwz, + gnatw_dot_a, + gnatw_dot_b, + gnatw_dot_c, + gnatw_dot_f, + gnatw_dot_h, + gnatw_dot_i, + gnatw_dot_j, + gnatw_dot_k, + gnatw_dot_l, + gnatw_dot_m, + gnatw_dot_n, + gnatw_dot_o, + gnatw_dot_p, + gnatw_dot_q, + gnatw_dot_r, + gnatw_dot_s, + gnatw_dot_t, + gnatw_dot_u, + gnatw_dot_v, + gnatw_dot_w, + gnatw_dot_x, + gnatw_dot_y, + gnatw_dot_z, + gnatw_underscore_a, + gnatw_underscore_c, + gnatw_underscore_j, + gnatw_underscore_l, + gnatw_underscore_p, + gnatw_underscore_q, + gnatw_underscore_r, + gnatw_underscore_s, + gnaty, + gnatya, + gnatyb, + gnatyc, + gnatyd, + gnatye, + gnatyf, + gnatyh, + gnatyi, + gnatyk, + gnatyl, + gnatym, + gnatyn, + gnatyo, + gnatyp, + gnatyr, + gnatys, + gnatyu, + gnatyx, + gnatyz, + gnatyaa, + gnatybb, + gnatycc, + gnatydd, + gnatyii, + gnatyll, + gnatymm, + gnatyoo, + gnatyss, + gnatytt, + gnatel + ); + + subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel; + -- The range of switch ids that represent switches that trigger a specific + -- diagnostic check. + + type Switch_Type is record + + Status : Status_Type := Active; + -- The status will indicate whether the switch is currently active, + -- or has been deprecated. A deprecated switch will not control + -- diagnostics, and will not be emitted by the GNAT usage. + + Human_Id : String_Ptr := null; + -- The Human_Id will be a unique and stable string-based ID which + -- identifies the content of the switch within the switch registry. + -- This ID will appear in SARIF readers. + + Short_Name : String_Ptr := null; + -- The Short_Name will denote the -gnatXX name of the switch. + + Description : String_Ptr := null; + -- The description will contain the description of the switch, as it is + -- currently emitted by the GNAT usage. + + Documentation_Url : String_Ptr := null; + -- The documentation_url will point to the AdaCore documentation site + -- for the switch. + + end record; + + type Diagnostic_Kind is + (Error, + Warning, + Default_Warning, + -- Warning representing the old warnings created with the '??' insertion + -- character. These warning have the [enabled by default] tag. + Restriction_Warning, + -- Warning representing the old warnings created with the '?*?' + -- insertion character. These warning have the [restriction warning] + -- tag. + Style, + Tagless_Warning, + -- Warning representing the old warnings created with the '?' insertion + -- character. + Info, + Info_Warning + -- Info warnings are old messages where both warning and info were set + -- to true. These info messages behave like warnings and are usually + -- accompanied by a warning tag. + ); + + type Diagnostic_Entry_Type is record + Status : Status_Type := Active; + + Human_Id : String_Ptr := null; + -- A human readable code for the diagnostic. If the diagnostic has a + -- switch with a human id then the human_id of the switch shall be used + -- in SARIF reports. + + Documentation : String_Ptr := null; + + Switch : Switch_Id := No_Switch_Id; + -- The switch that controls the diagnostic message. + end record; + + type Diagnostic_Type is record + + Id : Diagnostic_Id := No_Diagnostic_Id; + + Kind : Diagnostic_Kind := Error; + + Switch : Switch_Id := No_Switch_Id; + + Message : String_Ptr := null; + + Warn_Err : Boolean := False; + -- Signal whether the diagnostic was converted from a warning to an + -- error. This needs to be set during the message emission as this + -- behavior depends on the context of the code. + + Serious : Boolean := True; + -- Typically all errors are considered serious and the compiler should + -- stop its processing since the tree is essentially invalid. However, + -- some errors are not serious and the compiler can continue its + -- processing to discover more critical errors. + + Locations : Labeled_Span_List := Labeled_Span_Lists.Nil; + + Sub_Diagnostics : Sub_Diagnostic_List := Sub_Diagnostic_Lists.Nil; + + Fixes : Fix_List := Fix_Lists.Nil; + end record; + + procedure Destroy (Elem : in out Diagnostic_Type); + pragma Inline (Destroy); + + package Diagnostics_Lists is new Doubly_Linked_Lists + (Element_Type => Diagnostic_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Diagnostic_List is Diagnostics_Lists.Doubly_Linked_List; + + All_Diagnostics : Diagnostic_List := Diagnostics_Lists.Create; + + procedure Add_Location + (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type); + + procedure Add_Sub_Diagnostic + (Diagnostic : in out Diagnostic_Type; + Sub_Diagnostic : Sub_Diagnostic_Type); + + procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type); + + procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; + Update_Count : Boolean := True); + + procedure Print_Diagnostic (Diagnostic : Diagnostic_Type); + + function Primary_Location + (Diagnostic : Diagnostic_Type) return Labeled_Span_Type; + + type Labeled_Span_Array is + array (Positive range <>) of Labeled_Span_Type; + type Sub_Diagnostic_Array is + array (Positive range <>) of Sub_Diagnostic_Type; + type Fix_Array is + array (Positive range <>) of Fix_Type; + type Edit_Array is + array (Positive range <>) of Edit_Type; + + No_Locations : constant Labeled_Span_Array (1 .. 0) := (others => <>); + No_Sub_Diags : constant Sub_Diagnostic_Array (1 .. 0) := (others => <>); + No_Fixes : constant Fix_Array (1 .. 0) := (others => <>); + No_Edits : constant Edit_Array (1 .. 0) := (others => <>); + + function Make_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + return Diagnostic_Type; + + procedure Record_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes); + + function Labeled_Span (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type; + + function Primary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type; + + function Primary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type; + + function Secondary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type; + + function Secondary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type; + + function Sub_Diag (Msg : String; + Kind : Sub_Diagnostic_Kind := + Diagnostics.Continuation; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Continuation (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Help (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Suggestion (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Fix (Description : String; + Edits : Edit_Array; + Applicability : Applicability_Type := Unspecified) + return Fix_Type; + + function Edit (Text : String; + Span : Source_Span) + return Edit_Type; +end Diagnostics; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index c8d87f0f9bb..f4660c4e35c 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -33,6 +33,7 @@ with Atree; use Atree; with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; +with Diagnostics.Converter; use Diagnostics.Converter; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -163,13 +164,6 @@ package body Errout is -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is -- included as well. - procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); - -- Add a sequence of characters to the current message. The characters may - -- be one of the special insertion characters (see documentation in spec). - -- Flag is the location at which the error is to be posted, which is used - -- to determine whether or not the # insertion needs a file name. The - -- variables Msg_Buffer are set on return Msglen. - procedure Set_Posted (N : Node_Id); -- Sets the Error_Posted flag on the given node, and all its parents that -- are subexpressions and then on the parent non-subexpression construct @@ -2563,6 +2557,10 @@ package body Errout is -- Local subprograms + procedure Emit_Error_Msgs; + -- Emit all error messages in the table use the pretty printed format if + -- -gnatdF is used otherwise use the brief format. + procedure Write_Error_Summary; -- Write error summary @@ -2602,6 +2600,108 @@ package body Errout is -- SGR_Span is the SGR string to start the section of code in the span, -- that should be closed with SGR_Reset. + -------------------- + -- Emit_Error_Msgs -- + --------------------- + + procedure Emit_Error_Msgs is + Use_Prefix : Boolean; + E : Error_Msg_Id; + begin + Set_Standard_Error; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + + -- If -gnatdF is used, separate main messages from previous + -- messages with a newline (unless it is an info message) and + -- make continuation messages follow the main message with only + -- an indentation of two space characters, without repeating + -- file:line:col: prefix. + + Use_Prefix := + not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); + + if not Errors.Table (E).Deleted then + + if Debug_Flag_FF then + if Errors.Table (E).Msg_Cont then + Write_Str (" "); + elsif not Errors.Table (E).Info then + Write_Eol; + end if; + end if; + + if Use_Prefix then + Write_Str (SGR_Locus); + + if Full_Path_Name_For_Brief_Errors then + Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); + else + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + end if; + + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; + + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); + + Write_Str (SGR_Reset); + end if; + + Output_Msg_Text (E); + Write_Eol; + + -- If -gnatdF is used, write the source code line + -- corresponding to the location of the main message (unless + -- it is an info message). Also write the source code line + -- corresponding to an insertion location inside + -- continuation messages. + + if Debug_Flag_FF + and then not Errors.Table (E).Info + then + if Errors.Table (E).Msg_Cont then + declare + Loc : constant Source_Ptr := + Errors.Table (E).Insertion_Sloc; + begin + if Loc /= No_Location then + Write_Source_Code_Lines + (To_Span (Loc), SGR_Span => SGR_Note); + end if; + end; + + else + declare + SGR_Span : constant String := + (if Errors.Table (E).Info then SGR_Note + elsif Errors.Table (E).Warn + and then not Errors.Table (E).Warn_Err + then SGR_Warning + else SGR_Error); + begin + Write_Source_Code_Lines + (Errors.Table (E).Optr, SGR_Span); + end; + end if; + end if; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end Emit_Error_Msgs; + ------------------------- -- Write_Error_Summary -- ------------------------- @@ -3094,7 +3194,6 @@ package body Errout is E : Error_Msg_Id; Err_Flag : Boolean; - Use_Prefix : Boolean; -- Start of processing for Output_Messages @@ -3155,100 +3254,25 @@ package body Errout is Set_Standard_Output; - -- Brief Error mode - - elsif Brief_Output or (not Full_List and not Verbose_Mode) then - Set_Standard_Error; - - E := First_Error_Msg; - while E /= No_Error_Msg loop - - -- If -gnatdF is used, separate main messages from previous - -- messages with a newline (unless it is an info message) and - -- make continuation messages follow the main message with only - -- an indentation of two space characters, without repeating - -- file:line:col: prefix. - - Use_Prefix := - not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); - - if not Errors.Table (E).Deleted and then not Debug_Flag_KK then - - if Debug_Flag_FF then - if Errors.Table (E).Msg_Cont then - Write_Str (" "); - elsif not Errors.Table (E).Info then - Write_Eol; - end if; - end if; - - if Use_Prefix then - Write_Str (SGR_Locus); - - if Full_Path_Name_For_Brief_Errors then - Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); - else - Write_Name (Reference_Name (Errors.Table (E).Sfile)); - end if; - - Write_Char (':'); - Write_Int (Int (Physical_To_Logical - (Errors.Table (E).Line, - Errors.Table (E).Sfile))); - Write_Char (':'); - - if Errors.Table (E).Col < 10 then - Write_Char ('0'); - end if; - - Write_Int (Int (Errors.Table (E).Col)); - Write_Str (": "); + -- Do not print any messages if all messages are killed -gnatdK - Write_Str (SGR_Reset); - end if; + elsif Debug_Flag_KK then - Output_Msg_Text (E); - Write_Eol; + null; - -- If -gnatdF is used, write the source code line corresponding - -- to the location of the main message (unless it is an info - -- message). Also write the source code line corresponding to - -- an insertion location inside continuation messages. + -- Brief Error mode - if Debug_Flag_FF - and then not Errors.Table (E).Info - then - if Errors.Table (E).Msg_Cont then - declare - Loc : constant Source_Ptr := - Errors.Table (E).Insertion_Sloc; - begin - if Loc /= No_Location then - Write_Source_Code_Lines - (To_Span (Loc), SGR_Span => SGR_Note); - end if; - end; + elsif Brief_Output or (not Full_List and not Verbose_Mode) then - else - declare - SGR_Span : constant String := - (if Errors.Table (E).Info then SGR_Note - elsif Errors.Table (E).Warn - and then not Errors.Table (E).Warn_Err - then SGR_Warning - else SGR_Error); - begin - Write_Source_Code_Lines - (Errors.Table (E).Optr, SGR_Span); - end; - end if; - end if; - end if; + -- Use updated diagnostic mechanism - E := Errors.Table (E).Next; - end loop; + if Debug_Flag_Underscore_DD then + Convert_Errors_To_Diagnostics; - Set_Standard_Output; + Emit_Diagnostics; + else + Emit_Error_Msgs; + end if; end if; -- Full source listing case diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 2b0410ae690..fce7d9b502a 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -292,31 +292,31 @@ package Errout is -- not necessary to go through any computational effort to include it. -- -- Note: this usage is obsolete; use ?? ?*? ?$? ?x? ?.x? ?_x? to - -- specify the string to be added when Warn_Doc_Switch is set to True. - -- If this switch is True, then for simple ? messages it has no effect. - -- This simple form is to ease transition and may be removed later - -- except for GNATprove-specific messages (info and warnings) which are - -- not subject to the same GNAT warning switches. + -- specify the string to be added when Warning_Doc_Switch is set to + -- True. If this switch is True, then for simple ? messages it has no + -- effect. This simple form is to ease transition and may be removed + -- later except for GNATprove-specific messages (info and warnings) + -- which are not subject to the same GNAT warning switches. -- Insertion character ?? (Two question marks: default warning) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[enabled by default]" at the end of the warning message. For -- continuations, use this in each continuation message. -- Insertion character ?x? ?.x? ?_x? (warning with switch) -- "x" is a (lower-case) warning switch character. - -- Like ??, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ??, but if the flag Warning_Doc_Switch is True, adds the string -- "[-gnatwx]", "[-gnatw.x]", "[-gnatw_x]", or "[-gnatyx]" (for style -- messages), at the end of the warning message. For continuations, use -- this on each continuation message. -- Insertion character ?*? (restriction warning) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[restriction warning]" at the end of the warning message. For -- continuations, use this on each continuation message. -- Insertion character ?$? (elaboration informational messages) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[-gnatel]" at the end of the info message. This is used for the -- messages generated by the switch -gnatel. For continuations, use -- this on each continuation message. @@ -884,6 +884,13 @@ package Errout is -- ignored. A call with To=False restores the default treatment in which -- error calls are treated as usual (and as described in this spec). + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); + -- Add a sequence of characters to the current message. The characters may + -- be one of the special insertion characters (see documentation in spec). + -- Flag is the location at which the error is to be posted, which is used + -- to determine whether or not the # insertion needs a file name. The + -- variables Msg_Buffer are set on return Msglen. + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) renames Erroutc.Set_Warnings_Mode_Off; -- Called in response to a pragma Warnings (Off) to record the source diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index b2841104651..1174eb1c4e0 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -309,6 +309,16 @@ GNAT_ADA_OBJS = \ ada/cstand.o \ ada/debug.o \ ada/debug_a.o \ + ada/diagnostics-brief_emitter.o \ + ada/diagnostics-constructors.o \ + ada/diagnostics-converter.o \ + ada/diagnostics-json_utils.o \ + ada/diagnostics-pretty_emitter.o \ + ada/diagnostics-repository.o \ + ada/diagnostics-sarif_emitter.o \ + ada/diagnostics-switch_repository.o \ + ada/diagnostics-utils.o \ + ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ @@ -594,6 +604,16 @@ GNATBIND_OBJS = \ ada/casing.o \ ada/csets.o \ ada/debug.o \ + ada/diagnostics-brief_emitter.o \ + ada/diagnostics-constructors.o \ + ada/diagnostics-converter.o \ + ada/diagnostics-json_utils.o \ + ada/diagnostics-pretty_emitter.o \ + ada/diagnostics-repository.o \ + ada/diagnostics-sarif_emitter.o \ + ada/diagnostics-switch_repository.o \ + ada/diagnostics-utils.o \ + ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 29db89c6f52..12f9d652a85 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -334,6 +334,16 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \ uname.o urealp.o usage.o widechar.o warnsw.o \ seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \ + diagnostics-brief_emitter.o \ + diagnostics-constructors.o \ + diagnostics-converter.o \ + diagnostics-json_utils.o \ + diagnostics-pretty_emitter.o \ + diagnostics-repository.o \ + diagnostics-sarif_emitter.o \ + diagnostics-switch_repository.o \ + diagnostics-utils.o \ + diagnostics.o \ $(EXTRA_GNATMAKE_OBJS) # Make arch match the current multilib so that the RTS selection code diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb index cf118ab98df..5624df084bc 100644 --- a/gcc/ada/libgnat/g-lists.adb +++ b/gcc/ada/libgnat/g-lists.adb @@ -332,7 +332,7 @@ package body GNAT.Lists is -- The list has at least one outstanding iterator - if L.Iterators > 0 then + if Check_Tampering and then L.Iterators > 0 then raise Iterated; end if; end Ensure_Unlocked; diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads index 47459131a72..1a3c18efa70 100644 --- a/gcc/ada/libgnat/g-lists.ads +++ b/gcc/ada/libgnat/g-lists.ads @@ -64,6 +64,8 @@ package GNAT.Lists is with procedure Destroy_Element (Elem : in out Element_Type); -- Element destructor + Check_Tampering : Boolean := True; + package Doubly_Linked_Lists is --------------------- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index dd0c8b38954..aea52f3ad69 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1340,6 +1340,19 @@ package Opt is -- GNATMAKE, GNATLINK -- Set to False when no run_path_option should be issued to the linker + SARIF_File : Boolean := False; + -- GNAT + -- Output error and warning messages in SARIF format. Set to true when the + -- backend option "-fdiagnostics-format=sarif-file" is found on the + -- command line. The SARIF file is written to the file named: + -- .gnat.sarif + + SARIF_Output : Boolean := False; + -- GNAT + -- Output error and warning messages in SARIF format. Set to true when the + -- backend option "-fdiagnostics-format=sarif-stderr" is found on the + -- command line. + Search_Directory_Present : Boolean := False; -- GNAT -- Set to True when argument is -I. Reset to False when next argument, a diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 0345f8018ca..ec8acbb6524 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -28,6 +28,7 @@ with Stringt; use Stringt; with Uintp; use Uintp; with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; +with Diagnostics.Constructors; use Diagnostics.Constructors; separate (Par) package body Endh is @@ -896,6 +897,8 @@ package body Endh is procedure Output_End_Expected (Ins : Boolean) is End_Type : SS_End_Type; + Wrong_End_Start : Source_Ptr; + Wrong_End_Finish : Source_Ptr; begin -- Suppress message if this was a potentially junk entry (e.g. a record -- entry where no record keyword was present). @@ -932,8 +935,32 @@ package body Endh is elsif End_Type = E_Loop then if Error_Msg_Node_1 = Empty then - Error_Msg_SC -- CODEFIX - ("`END LOOP;` expected@ for LOOP#!"); + + if Debug_Flag_Underscore_DD then + + -- TODO: This is a quick hack to get the location of the + -- END LOOP for the demonstration. + + Wrong_End_Start := Token_Ptr; + + while Token /= Tok_Semicolon loop + Scan; -- past semicolon + end loop; + + Wrong_End_Finish := Token_Ptr; + + Restore_Scan_State (Scan_State); + + Record_End_Loop_Expected_Error + (End_Loc => To_Span (First => Wrong_End_Start, + Ptr => Wrong_End_Start, + Last => Wrong_End_Finish), + Start_Loc => Error_Msg_Sloc); + + else + Error_Msg_SC -- CODEFIX + ("`END LOOP;` expected@ for LOOP#!"); + end if; else Error_Msg_SC -- CODEFIX ("`END LOOP &;` expected@!"); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5cea155dc1e..ab8cc1012c3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -29,6 +29,7 @@ with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -5757,13 +5758,18 @@ package body Sem_Ch13 is if not Check_Primitive_Function (Subp) then if Present (Ref_Node) then - Error_Msg_N ("improper function for default iterator!", - Ref_Node); - Error_Msg_Sloc := Sloc (Subp); - Error_Msg_NE - ("\\default iterator defined # " - & "must be a primitive function", - Ref_Node, Subp); + if Debug_Flag_Underscore_DD then + Record_Default_Iterator_Not_Primitive_Error + (Ref_Node, Subp); + else + Error_Msg_N ("improper function for default iterator!", + Ref_Node); + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_NE + ("\\default iterator defined # " + & "must be a primitive function", + Ref_Node, Subp); + end if; end if; return False; @@ -15519,20 +15525,41 @@ package body Sem_Ch13 is -------------- procedure Too_Late is + S : Entity_Id; begin -- Other compilers seem more relaxed about rep items appearing too -- late. Since analysis tools typically don't care about rep items -- anyway, no reason to be too strict about this. if not Relaxed_RM_Semantics then - Error_Msg_N ("|representation item appears too late!", N); + if Debug_Flag_Underscore_DD then + + S := First_Subtype (T); + if Present (Freeze_Node (S)) then + Record_Representation_Too_Late_Error + (Rep => N, + Freeze => Freeze_Node (S), + Def => S); + else + Error_Msg_N ("|representation item appears too late!", N); + end if; + + else + Error_Msg_N ("|representation item appears too late!", N); + + S := First_Subtype (T); + if Present (Freeze_Node (S)) then + Error_Msg_NE + ("??no more representation items for }", + Freeze_Node (S), S); + end if; + end if; end if; end Too_Late; -- Local variables Parent_Type : Entity_Id; - S : Entity_Id; -- Start of processing for Rep_Item_Too_Late @@ -15566,14 +15593,6 @@ package body Sem_Ch13 is end if; Too_Late; - S := First_Subtype (T); - - if Present (Freeze_Node (S)) then - if not Relaxed_RM_Semantics then - Error_Msg_NE - ("??no more representation items for }", Freeze_Node (S), S); - end if; - end if; return True; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9b77a81e43e..9afaa896e20 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -27,6 +27,7 @@ with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -10861,40 +10862,86 @@ package body Sem_Ch4 is end loop; if No (Op_Id) then - Error_Msg_N ("invalid operand types for operator&", N); + if Debug_Flag_Underscore_DD then + if Nkind (N) /= N_Op_Concat then + if Nkind (N) in N_Op_Multiply | N_Op_Divide + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + else + Record_Invalid_Operand_Types_For_Operator_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + end if; + elsif Is_Access_Type (Etype (L)) then + Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op => N, + L => L); + + elsif Is_Access_Type (Etype (R)) then + Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op => N, + R => R); + else + Record_Invalid_Operand_Types_For_Operator_General_Error + (N); + end if; + else + Error_Msg_N ("invalid operand types for operator&", N); - if Nkind (N) /= N_Op_Concat then - Error_Msg_NE ("\left operand has}!", N, Etype (L)); - Error_Msg_NE ("\right operand has}!", N, Etype (R)); + if Nkind (N) /= N_Op_Concat then + Error_Msg_NE ("\left operand has}!", N, Etype (L)); + Error_Msg_NE ("\right operand has}!", N, Etype (R)); - -- For multiplication and division operators with - -- a fixed-point operand and an integer operand, - -- indicate that the integer operand should be of - -- type Integer. + -- For multiplication and division operators with + -- a fixed-point operand and an integer operand, + -- indicate that the integer operand should be of + -- type Integer. - if Nkind (N) in N_Op_Multiply | N_Op_Divide - and then Is_Fixed_Point_Type (Etype (L)) - and then Is_Integer_Type (Etype (R)) - then - Error_Msg_N ("\convert right operand to `Integer`", N); + if Nkind (N) in N_Op_Multiply | N_Op_Divide + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Error_Msg_N ("\convert right operand to `Integer`", N); - elsif Nkind (N) = N_Op_Multiply - and then Is_Fixed_Point_Type (Etype (R)) - and then Is_Integer_Type (Etype (L)) - then - Error_Msg_N ("\convert left operand to `Integer`", N); - end if; + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Error_Msg_N ("\convert left operand to `Integer`", N); + end if; - -- For concatenation operators it is more difficult to - -- determine which is the wrong operand. It is worth - -- flagging explicitly an access type, for those who - -- might think that a dereference happens here. + -- For concatenation operators it is more difficult to + -- determine which is the wrong operand. It is worth + -- flagging explicitly an access type, for those who + -- might think that a dereference happens here. - elsif Is_Access_Type (Etype (L)) then - Error_Msg_N ("\left operand is access type", N); + elsif Is_Access_Type (Etype (L)) then + Error_Msg_N ("\left operand is access type", N); - elsif Is_Access_Type (Etype (R)) then - Error_Msg_N ("\right operand is access type", N); + elsif Is_Access_Type (Etype (R)) then + Error_Msg_N ("\right operand is access type", N); + end if; end if; end if; end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index d52264a0278..b12db35e883 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -28,6 +28,8 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; +with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -68,7 +70,6 @@ with Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; - package body Sem_Ch9 is ----------------------- @@ -2222,10 +2223,18 @@ package body Sem_Ch9 is -- Pragma case else - Error_Msg_Name_1 := Pragma_Name (Prio_Item); - Error_Msg_NE - ("pragma% for & has no effect when Lock_Free given??", - Prio_Item, Id); + if Debug_Flag_Underscore_DD then + Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node => Prio_Item, + Pragma_Name => Pragma_Name (Prio_Item), + Lock_Free_Node => Id, + Lock_Free_Range => Parent (Id)); + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE + ("pragma% for & has no effect when Lock_Free given??", + Prio_Item, Id); + end if; end if; end if; end; From patchwork Thu Sep 5 08: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: 1981135 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=PaSbCCWs; 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 4WzsZd5Xzcz1yg7 for ; Thu, 5 Sep 2024 18:14:01 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 168B43864835 for ; Thu, 5 Sep 2024 08:13:59 +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 BC77C3850200 for ; Thu, 5 Sep 2024 08:11:13 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org BC77C3850200 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 BC77C3850200 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=1725523875; cv=none; b=PIRvdQ38rLzh4eMasyz3skQHJl+Nj9b/KUXm2kNIjKvbj1xB0SOPW3ZqjryHsMn4+YJ78HO2PzT53b+rZvEtO+i15blFLmnnbvrZKtY/97yw4cXSf20XmiWOAVWa4ceLCziu3sg2/nqx/qORsTwWqVA75ho7VOgQSBWmYYIv6bQ= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725523875; c=relaxed/simple; bh=IrpQM3jCVrfXmjkpZZGEGU3uIf/KNhkEfv0aRY5cP1Y=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=dEB5lSJ2oNJmMXlxJsELxVYaGEvqqbJQemqFipGfDfZH19yZLShgEbbEjaHsYMEGWfgDldiXJhuKYgBaQVjFGCY8iL0xU2+9yeYP5DlouPI5uQggInJboMbbtvcXte0qvSzIAuG1646g/nehjCnt1Qqa+6LfSbCs5Nq00w3GnKs= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32f.google.com with SMTP id 5b1f17b1804b1-42c7a49152aso4271205e9.2 for ; Thu, 05 Sep 2024 01:11:13 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1725523872; x=1726128672; 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=/es40Z7PTsen2bNT7nC6b0bU3+DH+I9+K7wZ/2aYu+c=; b=PaSbCCWsRQnuL1l9REREl40NxDPAW0paMWgdsP3Mv0r4ABg6YDhBG5g2HGXzgPJG2U P7oF9V2SUmn4iucnMDz3771qdwayK6HfZfnmtdQggPa/hN9MalkictRXoc7h/tuoyEI1 ql/H/M1sxHWekvThqc6qARmmxAZalVptZYoIG1EIE3nDNJgvXCsqDRjjiqb8K2m5h+H5 IWSPNNdIqI6orIHsPMkBr9Dp5+t547oP52Fu94mYkT3nzr8TuzNaCUpxJSg77jhSJwG3 sbh5UepK3TBwI5IJRZgCZuKU2e8UhbhSFKvFVxbtMZq6Xp652cgNGjxeemMIuql6eICb 1hLA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1725523872; x=1726128672; 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=/es40Z7PTsen2bNT7nC6b0bU3+DH+I9+K7wZ/2aYu+c=; b=r4LKj/6cLK32NcErKycpKOl5dCkjhZHH1bsWMxGFEK2HqWgrhmvx625OsjXpKPftCI M+vUlBdBLz6VV6ufxt9DF0rH3UWbu3WhhPq0zaaDTC6IuEhuuwDu4EcbNboC9GbLYawb oe/6LpwOI025fUOHEa0nX30z7DC8ugX8WHSNlleRL6fQQIWBAPlHTbq95evuXBESRPjf V8wBquHZLSC4HKYP9bxPjcFZbS70PiN0aUGVT7ILW/pDWcCWyR0kjvRTY+f6/8F8H3F5 N6T2RFehuN3rFBZy5XncgDG/uGY6w2yfx/zkYEN8NvA41/OKrzIPYu+vvkKjDH3FPL5v 99gw== X-Gm-Message-State: AOJu0Yz3VFnBULpleGnIlcXWmEaBHAEC0T8JkIKtz9HbCTcr7ZRK7Wgf 5ReKRZrOmVQ0Goj3f47UmXtq9vUMyFjd7OEmgs1dM8twEC3/b2cb31/Rff5fjKFiYYwlnJ8m4Ig = X-Google-Smtp-Source: AGHT+IHMDtD/Okv5b4z82Qc44RTv1fTuYcUdoZwcP68J/b8fo9y3KeIFBYBqjUsY7NxNvG+Ozr5uow== X-Received: by 2002:a05:600c:3ba3:b0:426:690d:d5b7 with SMTP id 5b1f17b1804b1-42c9a38b220mr13122125e9.25.1725523872425; Thu, 05 Sep 2024 01:11:12 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-42baf7fa745sm242524555e9.31.2024.09.05.01.11.11 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Sep 2024 01:11:12 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 4/6] ada: Remove unused parameters in validity checking routine Date: Thu, 5 Sep 2024 10:10:54 +0200 Message-ID: <20240905081056.2402112-4-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240905081056.2402112-1-poulhies@adacore.com> References: <20240905081056.2402112-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.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/ * exp_util.ads, exp_util.adb (Duplicate_Subexpr_No_Checks): Remove parameters, which are no longer used. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_util.adb | 18 ++++++------------ gcc/ada/exp_util.ads | 16 +++------------- 2 files changed, 9 insertions(+), 25 deletions(-) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8e5cdb7332e..9b67384755a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5049,23 +5049,17 @@ package body Exp_Util is --------------------------------- function Duplicate_Subexpr_No_Checks - (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False; - Related_Id : Entity_Id := Empty; - Is_Low_Bound : Boolean := False; - Is_High_Bound : Boolean := False) return Node_Id + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; begin Remove_Side_Effects - (Exp => Exp, - Name_Req => Name_Req, - Renaming_Req => Renaming_Req, - Related_Id => Related_Id, - Is_Low_Bound => Is_Low_Bound, - Is_High_Bound => Is_High_Bound); + (Exp => Exp, + Name_Req => Name_Req, + Renaming_Req => Renaming_Req); New_Exp := New_Copy_Tree (Exp); Remove_Checks (New_Exp); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 279feb2e6fe..49e75c79d35 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -457,24 +457,14 @@ package Exp_Util is -- following functions allow this behavior to be modified. function Duplicate_Subexpr_No_Checks - (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False; - Related_Id : Entity_Id := Empty; - Is_Low_Bound : Boolean := False; - Is_High_Bound : Boolean := False) return Node_Id; + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on the result, so that the duplicated expression does not include -- checks. This is appropriate for use when Exp, the original expression is -- unconditionally elaborated before the duplicated expression, so that -- there is no need to repeat any checks. - -- - -- Related_Id denotes the entity of the context where Expr appears. Flags - -- Is_Low_Bound and Is_High_Bound specify whether the expression to check - -- is the low or the high bound of a range. These three optional arguments - -- signal Remove_Side_Effects to create an external symbol of the form - -- Chars (Related_Id)_FIRST/_LAST. For suggested use of these parameters - -- see the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl. function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; From patchwork Thu Sep 5 08: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: 1981133 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=PQ2zIYUe; 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 4WzsXC2tYwz1yg7 for ; Thu, 5 Sep 2024 18:11:55 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8A57C386549E for ; Thu, 5 Sep 2024 08:11:53 +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 1F4A8386482F for ; Thu, 5 Sep 2024 08:11:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 1F4A8386482F 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 1F4A8386482F 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=1725523878; cv=none; b=OegNpSLobeaAZvRooL4NLPssq3SgcOtpKCggnij31yMAvSXbA9L+AR/ZzFEF2HfOkzta1n0kxPYp9VLBDxFwh/McvJStmALp50qqUz9SlgxTqv700yTU1cQeGgXZxS04UDvtLE6QUouyeam+29HwlAKvVpcfwmzo0QQmuay2w/g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725523878; c=relaxed/simple; bh=3D0xoNkV1QjPg7yM5Nw6pzX5FUVJetXDl7dprCS9Tpo=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=V+lSkaMjs32CkP3KiWZtd/tOPell7IsV9pZJW4YXKjQrI0pdrLoiAszt4u2TpKVEHjHiTFA0nWB2CdaK0KNRh5dpoz5h0MQEygEohPb3/tJZg2TzMOgjl5ggRoR3mDLO33V+Rc+sqLzrE1fMzdMNhKvcVGCDLOxsYU5dr/BMeMU= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x333.google.com with SMTP id 5b1f17b1804b1-42c7a49152aso4271415e9.2 for ; Thu, 05 Sep 2024 01:11:15 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1725523874; x=1726128674; 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=ajVrEDe9bUCvqHbiWl3XRWY75FP5fHdSQi+SvzX32Gg=; b=PQ2zIYUe+Q/ko5YzLhS6uWdPWl22Khu2cWmirGk++zwPiIkR5zrfGcoEURFfWqgFXB RP4jMBwqX1VlivESu3sp6vjReHtrenk8HIlq0XpCqu1EwzPUgA3lJfp0kNta1fcvtCFH fH51HSZ8FdhU8Fl6ih+v6+PgufPKfbMIRNM/oLVnbUG/qXg8O+XJBokSQl4D8ZnXTox5 +wjOr/Rs+0vj7cCSrfY13oMhhzEWxst4AvJTANjnWTn5bYwlsi+4DJRBlq3ojEcy0J60 7Kz9lTWldzfd1k+bOGGmm4dvU/UrrYP2mFjYUkNSZmfQjvAbK2FmEsFvsWv4Poljtmoz Dlsg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1725523874; x=1726128674; 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=ajVrEDe9bUCvqHbiWl3XRWY75FP5fHdSQi+SvzX32Gg=; b=gc0U/c6+/jqX4w2iwsoowQusJbdNXnDD2ERfhQJuqyKHdwbVPPAfYjGkK+p0dABHMh 7cDbj7N+V90xNPNwFaJ1TuA3tcag2Iwxz90mRfV/R4VYlOFFpv8KMeU0PGtgK64UVocY XheeaEDtsA8wj7MpvuDLBNSHCq8F9VRHmEZJTVqmzZDbzCiKy7Rpk5IgP/Gx3cgxM5H/ aFvP0oq/OvxKCbVRj7hZKdTY22wi/p6rBRbCUQa3nDbcAHwztad4VYx16AOiAnopQM44 dbMEqiJC+J8SXYjGusDcOP+ClM8jkKqiIiancEI/7TD2tBymShHZb50k+HjnJITPHPWe e/RQ== X-Gm-Message-State: AOJu0Yz8l1hP7ktttNU8HYHkvFxCnKO+K73Kd4yRKQxjFh/7QD3Ax7mz sK5fErupZSDShU6bQQB0IMGU6avK2gpgN17mBUnx2z1jYgKg11hpUqnzyZm0AmnAKTGwMn129U0 = X-Google-Smtp-Source: AGHT+IHMaIU6lO4ngI1abtwkDfddQuT83kiwyXheaNhQCpf6AV/TBed7gyyirLUWvCl2RsqtHKvMKw== X-Received: by 2002:a05:600c:6009:b0:428:e30:fa8d with SMTP id 5b1f17b1804b1-42c9a360294mr15436065e9.6.1725523873104; Thu, 05 Sep 2024 01:11:13 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-42baf7fa745sm242524555e9.31.2024.09.05.01.11.12 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Sep 2024 01:11:12 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 5/6] ada: Streamline handling of low-level peculiarities of record field layout Date: Thu, 5 Sep 2024 10:10:55 +0200 Message-ID: <20240905081056.2402112-5-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240905081056.2402112-1-poulhies@adacore.com> References: <20240905081056.2402112-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.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 This factors out the interface to the low-level field layout machinery. gcc/ada/ * gcc-interface/gigi.h (default_field_alignment): New function. * gcc-interface/misc.cc: Include tm_p header file. (default_field_alignment): New function. * gcc-interface/trans.cc (addressable_p) : Replace previous alignment klduge with call to default_field_alignment. * gcc-interface/utils.cc (finish_record_type): Likewise for the alignment based on which DECL_BIT_FIELD should be cleared. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/gigi.h | 4 ++++ gcc/ada/gcc-interface/misc.cc | 21 +++++++++++++++++++++ gcc/ada/gcc-interface/trans.cc | 24 +++++++----------------- gcc/ada/gcc-interface/utils.cc | 2 +- 4 files changed, 33 insertions(+), 18 deletions(-) diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 40f3f0d3d13..f4b302be3e0 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -1008,6 +1008,10 @@ extern bool must_pass_by_ref (tree gnu_type); /* Return the size of the FP mode with precision PREC. */ extern int fp_prec_to_size (int prec); +/* Return the default alignment of a FIELD of TYPE declared in a record or + union type as specified by the ABI of the target architecture. */ +extern unsigned int default_field_alignment (tree field, tree type); + /* Return the precision of the FP mode with size SIZE. */ extern int fp_size_to_prec (int size); diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc index 13cb39e91cb..ef5de7f5651 100644 --- a/gcc/ada/gcc-interface/misc.cc +++ b/gcc/ada/gcc-interface/misc.cc @@ -28,6 +28,7 @@ #include "coretypes.h" #include "target.h" #include "tree.h" +#include "tm_p.h" #include "diagnostic.h" #include "opts.h" #include "alias.h" @@ -1129,6 +1130,26 @@ must_pass_by_ref (tree gnu_type) && TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST)); } +/* Return the default alignment of a FIELD of TYPE declared in a record or + union type as specified by the ABI of the target architecture. */ + +unsigned int +default_field_alignment (tree ARG_UNUSED (field), tree type) +{ + /* This is modeled on layout_decl. */ + unsigned int align = TYPE_ALIGN (type); + +#ifdef BIGGEST_FIELD_ALIGNMENT + align = MIN (align, (unsigned int) BIGGEST_FIELD_ALIGNMENT); +#endif + +#ifdef ADJUST_FIELD_ALIGN + align = ADJUST_FIELD_ALIGN (field, type, align); +#endif + + return align; +} + /* This function is called by the front-end to enumerate all the supported modes for the machine, as well as some predefined C types. F is a function which is called back with the parameters as listed below, first a string, diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index c99b06670d5..9e9f5f8dcba 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -10291,23 +10291,13 @@ addressable_p (tree gnu_expr, tree gnu_type) /* Even with DECL_BIT_FIELD cleared, we have to ensure that the field is sufficiently aligned, in case it is subject to a pragma Component_Alignment. But we don't need to - check the alignment of the containing record, as it is - guaranteed to be not smaller than that of its most - aligned field that is not a bit-field. */ - && (DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) - >= TYPE_ALIGN (TREE_TYPE (gnu_expr)) -#ifdef TARGET_ALIGN_DOUBLE - /* Cope with the misalignment of doubles in records for - ancient 32-bit ABIs like that of x86/Linux. */ - || (DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) == 32 - && TYPE_ALIGN (TREE_TYPE (gnu_expr)) == 64 - && !TARGET_ALIGN_DOUBLE -#ifdef TARGET_64BIT - && !TARGET_64BIT -#endif - ) -#endif - )) + check the alignment of the containing record, since it + is guaranteed to be not smaller than that of its most + aligned field that is not a bit-field. However, we need + to cope with quirks of ABIs that may misalign fields. */ + && DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) + >= default_field_alignment (TREE_OPERAND (gnu_expr, 1), + TREE_TYPE (gnu_expr))) /* The field of a padding record is always addressable. */ || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 66e3192ea4f..60f36b1e50d 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -2220,7 +2220,7 @@ finish_record_type (tree record_type, tree field_list, int rep_level, if (DECL_BIT_FIELD (field) && operand_equal_p (this_size, TYPE_SIZE (type), 0)) { - const unsigned int align = TYPE_ALIGN (type); + const unsigned int align = default_field_alignment (field, type); /* In the general case, type alignment is required. */ if (value_factor_p (pos, align)) From patchwork Thu Sep 5 08: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: 1981136 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=YfA3/Zrd; 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 4Wzsc34G7gz1yXY for ; Thu, 5 Sep 2024 18:15:15 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 607C8386482F for ; Thu, 5 Sep 2024 08:15:13 +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 053D9386481D for ; Thu, 5 Sep 2024 08:11:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 053D9386481D 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 053D9386481D 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=1725523876; cv=none; b=un4g8IsrQyMXh5x/5HPgIRIQroIh3fWSXIfwAxWUzONHnuI3BYtXxUepulL9opNfT+HUIgSViHZ9be22RggwoAXlTJ9Bvb6bocZKj8+2uJd46dl0t0qoPVMuwa2HIN408HdcRwYfeQglLuEuLNf5v7YPEsIuC1eae1AZy+Sckfo= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1725523876; c=relaxed/simple; bh=klFPcaE/xBHCJ0fKoEOpne6U+zj5UYsJH2gZPElSjJU=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=h1+k5PyJQpZ+yifi0IMroCceeYRYXpH8oxVnzn0iqyTS1JeqyQ6Th0HzVHqoPy/hzXM39GYf9lnQ1X2PfiQAtkbh3kLeFidCQ99XIweFg0/i4Sq3QcnUscAXCv7K5MJ90PtjOL1eIrNbOBQhyGTMHryr7WQGod2HZmulEqhwHzo= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x32b.google.com with SMTP id 5b1f17b1804b1-42bbe908380so3481355e9.2 for ; Thu, 05 Sep 2024 01:11:14 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1725523874; x=1726128674; 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=h5oDFsZiN8gqWScu2vzemFlZBQi7NVU1D1hV4gwQ3jk=; b=YfA3/Zrdp6MwWAggDOYx3Wx4YDKyUM2zi7BTbXIrpKRM65BU95mS33nIos27kT9Fin At4y/75PTZ/Q8d7Pb84SKBNtqVtTOzTNYb0zd5eAwN2IzZ/wzmyGscjDl1224lo1zUBR aYmu84eUAY7MuWuG+xkgDuqfkIGivpKFyEceS/oCwWbKvoq3wwJdx2aXp5HUaYJ/Pkxb bAV4Te4Uv+WYJIRe34Yafco5BguV/XbK4GSz1mCLUkAyl9/OWojvPCANvG6s+XWrxjvi gpKwGEL5cGdp8w0Eap3bO2Ps4buIGuJsQXjXRbmi/Qir8q4DM6gMaW4yEWsI11emAF3G rmTw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1725523874; x=1726128674; 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=h5oDFsZiN8gqWScu2vzemFlZBQi7NVU1D1hV4gwQ3jk=; b=mPkojDkXW3fzRGEmpUAiuSsVby2ivaTrU0E2ua5GJ5iyPccwyMwsbQ7DaYijUHnljG DVRgX5JMBZ//NxKt/ZuG4XvPbzBDXqwtQGr/IFt5FULqmPqUz2FirQZI3Exsey4oEnxx 9oivgBhnsRGpDvYDHEgBTtX3jVdgzy63/Ig3/RnboGl3ZbPDnGebJZAfQSAvBd+YZXxj X5xEe0lty4XSwayM1W/+UWUDA+BRo4W6ibp+iYlOWqV/0r03/ou4zYof19aMmbOovCFp ritJPpnLdI53YIcLwc4CTzjDHe9I2+Vg4VJe1lE0Px+Sr2EUhg9jW2ULI1qZhqlK5FBz ySDA== X-Gm-Message-State: AOJu0YyGCLe2dsmzehhIVRnZ5yKBx/tNiUhcsI6JjBVRpwqaJxpe6ddU /IkI4vTX1nszOtKS4aiGPGOMY7k7f8nb8b+r83hG/MgtD+w0VLNze8h5/LtrEaCVsnrr0iu9cBY = X-Google-Smtp-Source: AGHT+IEUyILk4BLs1qzjkAx1DYEjTY9eLNWPvTekMDTJ4JjNLe+FqFA2pyqKScKtFwjscdGQeA3tWA== X-Received: by 2002:a05:600c:3b1b:b0:42a:a6d2:328b with SMTP id 5b1f17b1804b1-42bdc64e691mr114467745e9.30.1725523873719; Thu, 05 Sep 2024 01:11:13 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-42baf7fa745sm242524555e9.31.2024.09.05.01.11.13 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Sep 2024 01:11:13 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED 6/6] ada: Add bypass for internal fields on strict-alignment platforms Date: Thu, 5 Sep 2024 10:10:56 +0200 Message-ID: <20240905081056.2402112-6-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240905081056.2402112-1-poulhies@adacore.com> References: <20240905081056.2402112-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.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 This is required to support misalignment of tagged types in legacy code. gcc/ada/ * gcc-interface/trans.cc (addressable_p) : Add bypass for internal fields on strict-alignment platforms. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/trans.cc | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 9e9f5f8dcba..92e000686fb 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -10295,9 +10295,14 @@ addressable_p (tree gnu_expr, tree gnu_type) is guaranteed to be not smaller than that of its most aligned field that is not a bit-field. However, we need to cope with quirks of ABIs that may misalign fields. */ - && DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) - >= default_field_alignment (TREE_OPERAND (gnu_expr, 1), - TREE_TYPE (gnu_expr))) + && (DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) + >= default_field_alignment (TREE_OPERAND (gnu_expr, 1), + TREE_TYPE (gnu_expr)) + /* We do not enforce this on strict-alignment platforms for + internal fields in order to keep supporting misalignment + of tagged types in legacy code. */ + || (!STRICT_ALIGNMENT + && DECL_INTERNAL_P (TREE_OPERAND (gnu_expr, 1))))) /* The field of a padding record is always addressable. */ || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));