gdb/testsuite/gdb.guile/scm-symbol.exp

   1 # Copyright (C) 2010-2018 Free Software Foundation, Inc.
   2
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 3 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 # This file is part of the GDB testsuite.
  17 # It tests the mechanism exposing symbols to Guile.
  18
  19 load_lib gdb-guile.exp
  20
  21 standard_testfile
  22
  23 if {[prepare_for_testing "failed to prepare" $testfile $srcfile debug]} {
  24     return -1
  25 }
  26
  27 # Skip all tests if Guile scripting is not enabled.
  28 if { [skip_guile_tests] } { continue }
  29
  30 # These tests are done before we call gdb_guile_runto_main so we have to
  31 # import the gdb module ourselves.
  32 gdb_install_guile_utils
  33 gdb_install_guile_module
  34
  35 # Test looking up a global symbol before we runto_main as this is the
  36 # point where we don't have a current frame, and we don't want to
  37 # require one.
  38 gdb_scm_test_silent_cmd "guile (define main-func (lookup-global-symbol \"main\"))" \
  39     "lookup main"
  40 gdb_test "guile (print (symbol-function? main-func))" \
  41     "= #t" "test (symbol-function? main)"
  42 gdb_test "guile (print (lookup-global-symbol \"junk\"))" \
  43     "= #f" "test (lookup-global-symbol junk)"
  44
  45 gdb_test "guile (print (symbol-value main-func))" \
  46     "= {int \\(int, char \[*\]\[*\]\\)} $hex \\<main\\>" "print value of main"
  47
  48 set qq_line [gdb_get_line_number "line of qq"]
  49 gdb_scm_test_silent_cmd "guile (define qq-var (lookup-global-symbol \"qq\"))" \
  50     "lookup qq"
  51 gdb_test "guile (print (symbol-line qq-var))" \
  52     "= $qq_line" "print line number of qq"
  53 gdb_test "guile (print (symbol-value qq-var))" \
  54     "= 72" "print value of qq"
  55 gdb_test "guile (print (symbol-needs-frame? qq-var))" \
  56     "= #f" "print whether qq needs a frame"
  57
  58 if ![gdb_guile_runto_main] {
  59     return
  60 }
  61
  62 # Test symbol eq? and equal?.
  63 gdb_test "guile (print (eq? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
  64     "= #t"
  65 gdb_test "guile (print (equal? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
  66     "= #t"
  67
  68 gdb_breakpoint [gdb_get_line_number "Block break here."]
  69 gdb_continue_to_breakpoint "Block break here."
  70 gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
  71     "get frame at block break"
  72 gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
  73     "get block at block break"
  74
  75 # Test symbol-argument?.
  76 gdb_scm_test_silent_cmd "guile (define arg (car (lookup-symbol \"arg\")))" \
  77     "get variable arg"
  78 gdb_test "guile (print (symbol-variable? arg))" "= #f"
  79 gdb_test "guile (print (symbol-constant? arg))" "= #f"
  80 gdb_test "guile (print (symbol-argument? arg))" "= #t"
  81 gdb_test "guile (print (symbol-function? arg))" "= #f"
  82
  83 # Test symbol-function?.
  84 gdb_scm_test_silent_cmd "guile (define func (block-function block))" \
  85     "get block function"
  86 gdb_test "guile (print (symbol-variable? func))" "= #f"
  87 gdb_test "guile (print (symbol-constant? func))" "= #f"
  88 gdb_test "guile (print (symbol-argument? func))" "= #f"
  89 gdb_test "guile (print (symbol-function? func))" "= #t"
  90
  91 # Test attributes of func.
  92 gdb_test "guile (print (symbol-name func))" "func"
  93 gdb_test "guile (print (symbol-print-name func))" "func"
  94 gdb_test "guile (print (symbol-linkage-name func))" "func"
  95 gdb_test "guile (print (= (symbol-addr-class func) SYMBOL_LOC_BLOCK))" "= #t"
  96
  97 gdb_breakpoint [gdb_get_line_number "Break at end."]
  98 gdb_continue_to_breakpoint "Break at end."
  99 gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
 100     "get frame at end"
 101
 102 # Test symbol-variable?.
 103 gdb_scm_test_silent_cmd "guile (define a (car (lookup-symbol \"a\")))" \
 104     "get variable a"
 105 gdb_test "guile (print (symbol-variable? a))" "= #t"
 106 gdb_test "guile (print (symbol-constant? a))" "= #f"
 107 gdb_test "guile (print (symbol-argument? a))" "= #f"
 108 gdb_test "guile (print (symbol-function? a))" "= #f"
 109
 110 # Test attributes of a.
 111 gdb_test "guile (print (= (symbol-addr-class a) SYMBOL_LOC_COMPUTED))" "= #t"
 112
 113 gdb_test "guile (print (symbol-value a))" \
 114     "ERROR: Symbol requires a frame to compute its value.*"\
 115     "try to print value of a without a frame"
 116 gdb_test "guile (print (symbol-value a #:frame frame))" \
 117     "= 0" "print value of a"
 118 gdb_test "guile (print (symbol-needs-frame? a))" \
 119     "= #t" "print whether a needs a frame"
 120
 121 # Test symbol-constant?.
 122 gdb_scm_test_silent_cmd "guile (define t (car (lookup-symbol \"one\")))" \
 123     "get constant t"
 124 gdb_test "guile (print (symbol-variable? t))" "= #f"
 125 gdb_test "guile (print (symbol-constant? t))" "= #t"
 126 gdb_test "guile (print (symbol-argument? t))" "= #f"
 127 gdb_test "guile (print (symbol-function? t))" "= #f"
 128
 129 # Test attributes of t.
 130 gdb_test "guile (print (= (symbol-addr-class t) SYMBOL_LOC_CONST))" "= #t"
 131
 132 # Test type attribute.
 133 gdb_test "guile (print (symbol-type t))" "= enum tag"
 134
 135 # Test symtab attribute.
 136 gdb_test "guile (print (symbol-symtab t))" "= #<gdb:symtab .*gdb.guile/scm-symbol.c>"
 137
 138 # C++ tests
 139 # Recompile binary.
 140 if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}-cxx" executable "debug c++"] != "" } {
 141     untested "failed to compile in C++ mode"
 142     return -1
 143 }
 144
 145 # Start with a fresh gdb.
 146 gdb_exit
 147 gdb_start
 148 gdb_reinitialize_dir $srcdir/$subdir
 149 gdb_load ${binfile}-cxx
 150
 151 if ![gdb_guile_runto_main] {
 152     return
 153 }
 154
 155 gdb_breakpoint [gdb_get_line_number "Break in class."]
 156 gdb_continue_to_breakpoint "Break in class."
 157
 158 gdb_scm_test_silent_cmd "guile (define cplusframe (selected-frame))" \
 159     "get frame at class"
 160 gdb_scm_test_silent_cmd "guile (define cplusfunc (block-function (frame-block cplusframe)))" \
 161     "get function at class"
 162
 163 gdb_test "guile (print (symbol-variable? cplusfunc))" "= #f"
 164 gdb_test "guile (print (symbol-constant? cplusfunc))" "= #f"
 165 gdb_test "guile (print (symbol-argument? cplusfunc))" "= #f"
 166 gdb_test "guile (print (symbol-function? cplusfunc))" "= #t"
 167
 168 gdb_test "guile (print (symbol-name cplusfunc))" \
 169     "= SimpleClass::valueofi().*" "test method.name"
 170 gdb_test "guile (print (symbol-print-name cplusfunc))" \
 171     "= SimpleClass::valueofi().*" "test method.print_name"
 172 # FIXME: GDB is broken here and we're verifying broken behaviour.
 173 # (linkage-name should be the mangled name)
 174 gdb_test "guile (print (symbol-linkage-name cplusfunc))" \
 175     "SimpleClass::valueofi().*" "test method.linkage_name"
 176 gdb_test "guile (print (= (symbol-addr-class cplusfunc) SYMBOL_LOC_BLOCK))" "= #t"
 177
 178 # Test is_valid when the objfile is unloaded.  This must be the last
 179 # test as it unloads the object file in GDB.
 180 # Start with a fresh gdb.
 181 clean_restart ${testfile}
 182 if ![gdb_guile_runto_main] {
 183     return
 184 }
 185
 186 gdb_breakpoint [gdb_get_line_number "Break at end."]
 187 gdb_continue_to_breakpoint "Break at end."
 188 gdb_scm_test_silent_cmd "guile (define a (car (lookup-symbol \"a\")))" \
 189     "get variable a for unload"
 190 gdb_test "guile (print (symbol-valid? a))" \
 191     "= #t" "test symbol validity pre-unload"
 192 delete_breakpoints
 193 gdb_unload
 194 gdb_test "guile (print (symbol-valid? a))" \
 195     "= #f" "test symbol validity post-unload"
 196 gdb_test_no_output "guile (set! a #f) (gc)" "test symbol destructor"