From patchwork Thu Jun 13 13:33:35 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: 1947425 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=cRXEWzDa; 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 4W0Nvk42h9z20KL for ; Thu, 13 Jun 2024 23:45:22 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D15BA388216C for ; Thu, 13 Jun 2024 13:45:20 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x335.google.com (mail-wm1-x335.google.com [IPv6:2a00:1450:4864:20::335]) by sourceware.org (Postfix) with ESMTPS id 3D334388215D for ; Thu, 13 Jun 2024 13:34:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 3D334388215D 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 3D334388215D Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::335 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718285668; cv=none; b=o/UlcQsnS7p7DJdI565yq3/ZO1zsvFbvhmVPx+SgVQGQjIaLrP6NMLn0jCpzT0dSBkAQWUo6+aJsSJ4TwDeALeOtYg2nXVvFe21xtu793O+qIltRbLyoskGX1hMQqfFwLhb4Op1hOKcXyVKRvjF+74pJdRpjyFkAU6/4XiOTBHk= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718285668; c=relaxed/simple; bh=nPOcUSKnHIRt1+OtnuWSjrOpJO7jRMMJBCKgESYR/4U=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=h25t7mpnxwPzNJgCPdzrOcy3TsTVyFGLyVNXv/tWMp9UdRvE16/majsMbJWjlZEdW4fjAPq6ALpE/U5chtHyvik33vWg0DxdLhgCrlSkyzy1JoUqM8Swo+yfv6qiNQOfFUA7s0/vm/LbVMoCGGtBWOO45K8c0Daeq5UO7g8lECk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x335.google.com with SMTP id 5b1f17b1804b1-4218180a122so7841555e9.1 for ; Thu, 13 Jun 2024 06:34:15 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1718285654; x=1718890454; 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=k1bzj0nvjmzsGaEdnFPdRyR0cWcNEza6EearAV/IOBA=; b=cRXEWzDa4fF+9AZm5WLz2Hv1OX26kESs/VB9ry5Lasum31JwRSDDHo6+A+R9Qz0+nV ERsVN6kMFoKlmYGce24T9GRzYDjbYTIZD7q1oRpCFagekCUJa1+gdeu1X51YcJQK9dXU RBsCV8vNZsriKGoN7tP5VgEXzU3Dv3mmaqVk45LvQVVghdKDpr4D6CaiAD5Ec1btUbhj s7qtX3JAKFXm+wUWzD7H5n1eWHhSJJKosH8+ovK/y+TCoIKTJNLfRDJi0Loxs4O2A6mP NkFkni4k5RC+cr06X0cX61hbHUxhcG4jlKleQBp9cTVW3cuggChZsgUXIabQhLO6Z0HX GmtQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1718285654; x=1718890454; 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=k1bzj0nvjmzsGaEdnFPdRyR0cWcNEza6EearAV/IOBA=; b=fq7T4fd5wxx3eMp804xb1M0FhumHnCMS7x1+7kBvWd1xM6DcDTyTkKljNzjNk5VXBr 2ZPAnXdtpw30Czo46f/VDOL/7a9i4GjBtE4K3uXBnr//4baLRnFHGFeBGHJ+wkYpLRvy F4Fppuk7120LephZAs/UdxIpx6TIy3VCUVvqabs1hpZOw53XnVdwrGiapvrIGWOkRkmW ESTjLuHw6OyNtAOK7jet4Dtc2ydnp9GWKBEruVC1VLGDebOhbJcJIUOeDD7Y000ranbm OrFd9DkGlIhQeINPOGOluYCbqBPfa1KO4u1pSu7Pxn2AkA+0dnbO2W/x3g1XRQhwNEJ9 FmLA== X-Gm-Message-State: AOJu0YyvuxkasCg58bL+/kP2tXzmlk2wo5XhoexjKGHM4DQNHwVyoh61 sOb/1IKDL2lvXdzZbUYWRwO2r0rh+rPk1vaPC9kM40T0PI0hNmWT+cm/AP7GtJJAUg1O70MssCo = X-Google-Smtp-Source: AGHT+IHR0wV4+2qCASgWl+Y/XulGDvD/XasRKlUurTztqQol5IY7aeqfLNIPiMeT8p8aHBT6NQyg1A== X-Received: by 2002:a05:600c:5117:b0:41a:908c:b841 with SMTP id 5b1f17b1804b1-422865ac05amr52941995e9.32.1718285653726; Thu, 13 Jun 2024 06:34: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-422870e9145sm62391955e9.22.2024.06.13.06.34.13 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 13 Jun 2024 06:34:13 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Viljar Indus Subject: [COMMITTED 29/30] ada: Remove -gnatdJ switch Date: Thu, 13 Jun 2024 15:33:35 +0200 Message-ID: <20240613133338.1809385-29-poulhies@adacore.com> X-Mailer: git-send-email 2.45.1 In-Reply-To: <20240613133338.1809385-1-poulhies@adacore.com> References: <20240613133338.1809385-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, 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 Using -gnatdJ with various other switches was error prone. Remove this switch since the primary users of this mode GNATCheck and Codepeer no longer need it. gcc/ada/ * debug.adb: Remove mentions of -gnatdJ. * errout.adb: Remove printing subprogram names to JSON. * erroutc.adb: Remove printing subprogram names in messages. * erroutc.ads: Remove Node and Subprogram_Name_Ptr used for -gnatdJ. * errutil.adb: Remove Node used for -gnatdJ * gnat1drv.adb: Remove references of -gnatdJ and Include_Subprgram_In_Messages. * opt.ads: Remove Include_Subprgram_In_Messages * par-util.adb: Remove behavior related to Include_Subprgram_In_Messages. * sem_util.adb: Remove Subprogram_Name used for -gnatdJ Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/debug.adb | 6 --- gcc/ada/errout.adb | 62 +++++++---------------- gcc/ada/erroutc.adb | 20 +------- gcc/ada/erroutc.ads | 18 ------- gcc/ada/errutil.adb | 3 +- gcc/ada/gnat1drv.adb | 7 --- gcc/ada/opt.ads | 4 -- gcc/ada/par-util.adb | 6 --- gcc/ada/sem_util.adb | 116 ------------------------------------------- 9 files changed, 22 insertions(+), 220 deletions(-) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 540db2a9942..602a8fa0b63 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -67,7 +67,6 @@ package body Debug is -- dG Generate all warnings including those normally suppressed -- dH Hold (kill) call to gigi -- dI Inhibit internal name numbering in gnatG listing - -- dJ Prepend subprogram name in messages -- dK Kill all error messages -- dL Ignore external calls from instances for elaboration -- dM Assume all variables are modified (no current values) @@ -615,11 +614,6 @@ package body Debug is -- is used in the fixed bugs run to minimize system and version -- dependency in filed -gnatD or -gnatG output. - -- dJ Prepend the name of the enclosing subprogram in compiler messages - -- (errors, warnings, style checks). This is useful in particular to - -- integrate compiler warnings in static analysis tools such as - -- CodePeer. - -- dK Kill all error messages. This debug flag suppresses the output -- of all error messages. It is used in regression tests where the -- error messages are target dependent and irrelevant. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 92c4f6a4635..76c461a2fd7 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -100,8 +100,7 @@ package body Errout is (Msg : String; Span : Source_Span; Opan : Source_Span; - Msg_Cont : Boolean; - Node : Node_Id); + Msg_Cont : Boolean); -- This is the low-level routine used to post messages after dealing with -- the issue of messages placed on instantiations (which get broken up -- into separate calls in Error_Msg). Span is the location on which the @@ -112,9 +111,7 @@ package body Errout is -- copy. So typically we can see Opan pointing to the template location -- in an instantiation copy when Span points to the source location of -- the actual instantiation (i.e the line with the new). Msg_Cont is - -- set true if this is a continuation message. Node is the relevant - -- Node_Id for this message, to be used to compute the enclosing entity if - -- Opt.Include_Subprogram_In_Messages is set. + -- set true if this is a continuation message. function No_Warnings (N : Node_Or_Entity_Id) return Boolean; -- Determines if warnings should be suppressed for the given node @@ -475,7 +472,7 @@ package body Errout is -- Error_Msg_Internal to place the message in the requested location. if Instantiation (Sindex) = No_Location then - Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False, N); + Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False); return; end if; @@ -573,32 +570,28 @@ package body Errout is (Msg => "info: in inlined body #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); elsif Is_Warning_Msg then Error_Msg_Internal (Msg => Warn_Insertion & "in inlined body #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); elsif Is_Style_Msg then Error_Msg_Internal (Msg => "style: in inlined body #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); else Error_Msg_Internal (Msg => "error in inlined body #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); end if; -- Case of generic instantiation @@ -609,32 +602,28 @@ package body Errout is (Msg => "info: in instantiation #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); elsif Is_Warning_Msg then Error_Msg_Internal (Msg => Warn_Insertion & "in instantiation #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); elsif Is_Style_Msg then Error_Msg_Internal (Msg => "style: in instantiation #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); else Error_Msg_Internal (Msg => "instantiation error #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); end if; end if; end if; @@ -653,8 +642,7 @@ package body Errout is (Msg => Msg, Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, - Msg_Cont => Msg_Cont_Status, - Node => N); + Msg_Cont => Msg_Cont_Status); end; end Error_Msg; @@ -944,8 +932,7 @@ package body Errout is (Msg : String; Span : Source_Span; Opan : Source_Span; - Msg_Cont : Boolean; - Node : Node_Id) + Msg_Cont : Boolean) is Sptr : constant Source_Ptr := Span.Ptr; Optr : constant Source_Ptr := Opan.Ptr; @@ -1247,8 +1234,7 @@ package body Errout is Serious => Is_Serious_Error, Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, - Deleted => False, - Node => Node)); + Deleted => False)); Cur_Msg := Errors.Last; -- Test if warning to be treated as error @@ -1471,8 +1457,7 @@ package body Errout is (Msg => Msg, Span => Span, Opan => Opan, - Msg_Cont => True, - Node => Node); + Msg_Cont => True); end; end if; end Error_Msg_Internal; @@ -2026,9 +2011,9 @@ package body Errout is -- Warn for unmatched Warnings (Off, ...) if SWE.Open then - Error_Msg_N + Error_Msg ("?.w?pragma Warnings Off with no matching Warnings On", - SWE.Node); + SWE.Start); -- Warn for ineffective Warnings (Off, ..) @@ -2041,9 +2026,9 @@ package body Errout is and then not (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W") then - Error_Msg_N + Error_Msg ("?.w?no warning suppressed by this pragma", - SWE.Node); + SWE.Start); end if; end if; end; @@ -2394,9 +2379,6 @@ package body Errout is -- whose value is the JSON location of Error.Sptr.Ptr. If Sptr.First and -- Sptr.Last are different from Sptr.Ptr, they will be printed as JSON -- locations under the names "start" and "finish". - -- When Include_Subprogram_In_Messages is true (-gnatdJ) an additional, - -- non-standard, attribute named "subprogram" will be added, allowing - -- precisely identifying the subprogram surrounding the span. ----------------------- -- Is_Continuation -- @@ -2473,12 +2455,6 @@ package body Errout is Write_JSON_Location (Span.Last); end if; - if Include_Subprogram_In_Messages then - Write_Str (",""subprogram"":"""); - Write_JSON_Escaped_String (Subprogram_Name_Ptr (Error.Node)); - Write_Str (""""); - end if; - Write_Str ("}"); end Write_JSON_Span; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index cef04d5daf2..f404018c44d 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -339,7 +339,6 @@ package body Erroutc is w (" Uncond = ", E.Uncond); w (" Msg_Cont = ", E.Msg_Cont); w (" Deleted = ", E.Deleted); - w (" Node = ", Int (E.Node)); Write_Eol; end dmsg; @@ -698,20 +697,7 @@ package body Erroutc is -- Postfix warning tag to message if needed if Tag /= "" and then Warning_Doc_Switch then - if Include_Subprogram_In_Messages then - Txt := - new String' - (Subprogram_Name_Ptr (E_Msg.Node) & - ": " & Text.all & ' ' & Tag); - else - Txt := new String'(Text.all & ' ' & Tag); - end if; - - elsif Include_Subprogram_In_Messages - and then (E_Msg.Warn or else E_Msg.Style) - then - Txt := - new String'(Subprogram_Name_Ptr (E_Msg.Node) & ": " & Text.all); + Txt := new String'(Text.all & ' ' & Tag); else Txt := Text; end if; @@ -744,8 +730,7 @@ package body Erroutc is elsif E_Msg.Warn then Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all); - -- No prefix needed for style message, "(style)" is there already, - -- although not necessarily in first position if -gnatdJ is used. + -- No prefix needed for style message, "(style)" is there already elsif E_Msg.Style then if Txt (Txt'First .. Txt'First + 6) = "(style)" then @@ -1674,7 +1659,6 @@ package body Erroutc is ((Start => Loc, Msg => new String'(Msg), Stop => Source_Last (Get_Source_File_Index (Loc)), - Node => Node, Reason => Reason, Open => True, Used => Used, diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 1c43bce2b21..5d48d5b899f 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -149,11 +149,6 @@ package Erroutc is -- output. This is used for internal processing for the case of an -- illegal instantiation. See Error_Msg routine for further details. - type Subprogram_Name_Type is access function (N : Node_Id) return String; - Subprogram_Name_Ptr : Subprogram_Name_Type; - -- Indirect call to Sem_Util.Subprogram_Name to break circular - -- dependency with the static elaboration model. - ---------------------------- -- Message ID Definitions -- ---------------------------- @@ -276,11 +271,6 @@ package Erroutc is Deleted : Boolean; -- If this flag is set, the message is not printed. This is used -- in the circuit for deleting duplicate/redundant error messages. - - Node : Node_Id; - -- If set, points to the node relevant for this message which will be - -- used to compute the enclosing subprogram name if - -- Opt.Include_Subprogram_In_Messages is set. end record; package Errors is new Table.Table ( @@ -352,14 +342,6 @@ package Erroutc is -- Starting and ending source pointers for the range. These are always -- from the same source file. - Node : Node_Id; - -- Node for the pragma Warnings occurrence. We store it to compute the - -- enclosing subprogram if -gnatdJ is enabled and a message about this - -- clause needs to be emitted. Note that we cannot remove the Start - -- component above and use Sloc (Node) on message display instead - -- because -gnatD output can already have messed with slocs at the point - -- when warnings about ineffective clauses are emitted. - Reason : String_Id; -- Reason string from pragma Warnings, or null string if none diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index bac9d4b15f1..4f5aa216461 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -223,8 +223,7 @@ package body Errutil is Serious => Is_Serious_Error, Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, - Deleted => False, - Node => Empty)); + Deleted => False)); Cur_Msg := Errors.Last; Prev_Msg := No_Error_Msg; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 081d9435f4a..754dab82862 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -207,13 +207,6 @@ procedure Gnat1drv is Error_To_Warning := True; end if; - -- -gnatdJ sets Include_Subprogram_In_Messages, adding the related - -- subprogram as part of the error and warning messages. - - if Debug_Flag_JJ then - Include_Subprogram_In_Messages := True; - end if; - -- Disable CodePeer_Mode in Check_Syntax, since we need front-end -- expansion. diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 5f402cf5d6e..d24b9b941ff 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -816,10 +816,6 @@ package Opt is -- cause implicit packing instead of generating an error message. Set by -- use of pragma Implicit_Packing. - Include_Subprogram_In_Messages : Boolean := False; - -- GNAT - -- Set True to include the enclosing subprogram in compiler messages. - Init_Or_Norm_Scalars : Boolean := False; -- GNAT, GNATBIND -- Set True if a pragma Initialize_Scalars applies to the current unit. diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 8ed5947f4a0..f254026431f 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -689,12 +689,6 @@ package body Util is pragma Assert (Scope.Last > 0); Scope.Decrement_Last; - if Include_Subprogram_In_Messages - and then Scopes (Scope.Last).Labl /= Error - then - Current_Node := Scopes (Scope.Last).Labl; - end if; - if Debug_Flag_P then Error_Msg_Uint_1 := UI_From_Int (Scope.Last); Error_Msg_SC ("decrement scope stack ptr, new value = ^!"); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3d12f552f41..1705b5817b9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -30,7 +30,6 @@ with Debug; use Debug; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; -with Erroutc; use Erroutc; with Exp_Ch6; use Exp_Ch6; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; @@ -171,12 +170,6 @@ package body Sem_Util is -- routine does not take simple flow diagnostics into account, it relies on -- static facts such as the presence of null exclusions. - function Subprogram_Name (N : Node_Id) return String; - -- Return the fully qualified name of the enclosing subprogram for the - -- given node N, with file:line:col information appended, e.g. - -- "subp:file:line:col", corresponding to the source location of the - -- body of the subprogram. - ----------------------------- -- Abstract_Interface_List -- ----------------------------- @@ -28074,113 +28067,6 @@ package body Sem_Util is and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); end Subject_To_Loop_Entry_Attributes; - --------------------- - -- Subprogram_Name -- - --------------------- - - function Subprogram_Name (N : Node_Id) return String is - Buf : Bounded_String; - Ent : Node_Id := N; - Nod : Node_Id; - - begin - while Present (Ent) loop - case Nkind (Ent) is - when N_Subprogram_Body => - Ent := Defining_Unit_Name (Specification (Ent)); - exit; - - when N_Subprogram_Declaration => - Nod := Corresponding_Body (Ent); - - if Present (Nod) then - Ent := Nod; - else - Ent := Defining_Unit_Name (Specification (Ent)); - end if; - - exit; - - when N_Subprogram_Instantiation - | N_Package_Body - | N_Package_Specification - => - Ent := Defining_Unit_Name (Ent); - exit; - - when N_Protected_Type_Declaration => - Ent := Corresponding_Body (Ent); - exit; - - when N_Protected_Body - | N_Task_Body - => - Ent := Defining_Identifier (Ent); - exit; - - when N_Entity => - exit; - - when others => - null; - end case; - - Ent := Parent (Ent); - end loop; - - if No (Ent) then - return "unknown subprogram:unknown file:0:0"; - end if; - - -- If the subprogram is a child unit, use its simple name to start the - -- construction of the fully qualified name. - - if Nkind (Ent) = N_Defining_Program_Unit_Name then - Ent := Defining_Identifier (Ent); - end if; - - Append_Entity_Name (Buf, Ent); - - -- Append homonym number if needed - - if Nkind (N) in N_Entity and then Has_Homonym (N) then - declare - H : Entity_Id := Homonym (N); - Nr : Nat := 1; - - begin - while Present (H) loop - if Scope (H) = Scope (N) then - Nr := Nr + 1; - end if; - - H := Homonym (H); - end loop; - - if Nr > 1 then - Append (Buf, '#'); - Append (Buf, Nr); - end if; - end; - end if; - - -- Append source location of Ent to Buf so that the string will - -- look like "subp:file:line:col". - - declare - Loc : constant Source_Ptr := Sloc (Ent); - begin - Append (Buf, ':'); - Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); - Append (Buf, ':'); - Append (Buf, Nat (Get_Logical_Line_Number (Loc))); - Append (Buf, ':'); - Append (Buf, Nat (Get_Column_Number (Loc))); - end; - - return +Buf; - end Subprogram_Name; - ------------------------------- -- Support_Atomic_Primitives -- ------------------------------- @@ -31395,6 +31281,4 @@ package body Sem_Util is end Storage_Model_Support; -begin - Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; end Sem_Util;