https://gcc.gnu.org/g:b599498e1842ef00a298d7c423a2dcd3859a3bca

commit r15-5574-gb599498e1842ef00a298d7c423a2dcd3859a3bca
Author: David Malcolm <dmalc...@redhat.com>
Date:   Thu Nov 21 14:36:16 2024 -0500

    testsuite: add print-stack.exp
    
    I wrote this support file to help me debug Tcl issues in the
    testsuite.
    
    Adding a call to:
    
      print_stack_backtrace
    
    somewhere in a .exp file (along with "load_lib print-stack.exp") leads
    to the interpreter printing a backtrace in a form that e.g. Emacs can
    consume, with filename:linenum: lines, and quoting the line of .exp
    source code.
    
    Fer example, adding a print_stack_backtrace to scansarif.exp in
    run-sarif-pytest I get this output:
    
    VVV START OF BACKTRACE VVV
      /home/david/coding/gcc-newgit/src/gcc/testsuite/lib/scansarif.exp:142: 
frame 16 in proc print_stack_backtrace
        142 |     print_stack_backtrace
      <proc>: frame 15 in proc run-sarif-pytest
      <eval>: frame 14 in proc dg-final-proc
      /usr/share/dejagnu/dg.exp:851: frame 13 in proc dg-final-proc
        851 |       if {[catch "dg-final-proc $prog" errmsg]} {
      <eval>: frame 12 in proc saved-dg-test
      /home/david/coding/gcc-newgit/src/gcc/testsuite/lib/gcc-dg.exp:1080: 
frame 11 in proc saved-dg-test
        1080 |      if { [ catch { eval saved-dg-test $args } errmsg ] } {
      /usr/share/dejagnu/dg.exp:559: frame 10 in proc dg-test
        559 |       dg-test $testcase $options ${default-extra-options}
      
/home/david/coding/gcc-newgit/src/gcc/testsuite/gcc.dg/sarif-output/sarif-output.exp:28:
 frame 9
        28 | dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.c]] "" ""
      <eval>: frame 8
      <eval>: frame 7
      /usr/share/dejagnu/runtest.exp:1460: frame 6
        1460 |      if { [catch "uplevel #0 source $test_file_name"] == 1 } {
      /usr/share/dejagnu/runtest.exp:1886: frame 5 in proc dg-runtest
        1886 |                      runtest $test_name
      /usr/share/dejagnu/runtest.exp:1845: frame 4 in proc dg-runtest
        1845 |                  foreach test_name [lsort [find ${dir} *.exp]] {
      /usr/share/dejagnu/runtest.exp:1788: frame 3 in proc dg-runtest
        1788 |          foreach dir "${test_top_dirs}" {
      /usr/share/dejagnu/runtest.exp:1669: frame 2 in proc dg-runtest
        1669 |     foreach pass $multipass {
      /usr/share/dejagnu/runtest.exp:1619: frame 1 in proc dg-runtest
        1619 | foreach current_target $target_list {
    ^^^  END OF BACKTRACE  ^^^
    
    and can click on the lines in Emacs's compilation buffer to take
    me to the relevant places.
    
    I found this made it *much* easier to debug my .exp files.  That
    said, I'm uncomfortable with Tcl, and so
    (a) there may be a better way of doing this
    (b) I may have made mistakes
    
    gcc/testsuite/ChangeLog:
            * lib/print-stack.exp: New file.
    
    Signed-off-by: David Malcolm <dmalc...@redhat.com>

Diff:
---
 gcc/testsuite/lib/print-stack.exp | 62 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 62 insertions(+)

diff --git a/gcc/testsuite/lib/print-stack.exp 
b/gcc/testsuite/lib/print-stack.exp
new file mode 100644
index 000000000000..d83b9c89d388
--- /dev/null
+++ b/gcc/testsuite/lib/print-stack.exp
@@ -0,0 +1,62 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+#  Contributed by David Malcolm <dmalc...@redhat.com>.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT 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
+# along with GCC; see the file COPYING3.  If not see
+# <http://www.gnu.org/licenses/>.
+
+# Get the 1-based line for LINENUM from FILENAME as a string
+
+proc get_line { filename linenum } {
+    set f [open $filename]
+    set lines [split [read $f] \n]
+    close $f
+    return [lindex $lines [expr $linenum - 1] ]
+}
+
+# Print a backtrace of the Tcl interpreter's stack, showing
+# frames, levels, source file and line where available.
+#
+# This isn't used anywhere, but is occasionally very helpful
+# to use when debugging.
+
+proc print_stack_backtrace {} {
+    set current_frame_level [info frame]
+    puts "VVV START OF BACKTRACE VVV"
+    for {set i [expr $current_frame_level - 1]} {$i > 0} {incr i -1} {
+       set frame [info frame $i]
+       if { [dict exists $frame "level"] } {
+           set level_num [dict get $frame "level"]
+           set relative_level_offset [expr 1 - $level_num]
+           set level [info level $relative_level_offset]
+           set procname [lindex $level 0]
+           # TODO: args = rest of $level, but this can be very long
+       } else {
+           set procname ""
+       }
+       set suffix ""
+       if { $procname != "" } {
+           set suffix " in proc $procname"
+       }
+       if { [dict get $frame "type"] == "source" } {
+           set fname [dict get $frame "file"]
+           set line [dict get $frame "line"]
+           puts "  $fname:$line: frame $i$suffix"
+           puts "    $line | [get_line $fname $line]"
+       } else {
+           set type [dict get $frame "type"]
+           puts "  <$type>: frame $i$suffix"
+       }
+    }
+    puts "^^^  END OF BACKTRACE  ^^^"
+}

Reply via email to