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

   1 # Copyright (C) 2008-2014 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 values to Guile.
  18
  19 load_lib gdb-guile.exp
  20
  21 standard_testfile
  22
  23 # Build inferior to language specification.
  24 # LANG is one of "c" or "c++".
  25 proc build_inferior {exefile lang} {
  26     global srcdir subdir srcfile testfile hex
  27
  28     # Use different names for .o files based on the language.
  29     # For Fission, the debug info goes in foo.dwo and we don't want,
  30     # for example, a C++ compile to clobber the dwo of a C compile.
  31     # ref: http://gcc.gnu.org/wiki/DebugFission
  32     switch ${lang} {
  33         "c" { set filename ${testfile}.o }
  34         "c++" { set filename ${testfile}-cxx.o }
  35     }
  36     set objfile [standard_output_file $filename]
  37
  38     if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${objfile}" object "debug $lang"] != ""
  39          || [gdb_compile "${objfile}" "${exefile}" executable "debug $lang"] != "" } {
  40         untested "Couldn't compile ${srcfile} in $lang mode"
  41         return -1
  42     }
  43     return 0
  44 }
  45
  46 proc test_value_in_inferior {} {
  47     global gdb_prompt
  48     global testfile
  49
  50     gdb_breakpoint [gdb_get_line_number "break to inspect struct and union"]
  51
  52     gdb_continue_to_breakpoint "break to inspect struct and union"
  53
  54     # Just get inferior variable s in the value history, available to guile.
  55     gdb_test "print s" "= {a = 3, b = 5}" ""
  56
  57     gdb_scm_test_silent_cmd "gu (define s (history-ref 0))" "set s"
  58
  59     gdb_test "gu (print (value-field s \"a\"))" \
  60         "= 3" "access element inside struct using string name"
  61
  62     # Append value in the value history.
  63     gdb_scm_test_silent_cmd "gu (define i (history-append! (make-value 42)))" \
  64         "append 42"
  65
  66     gdb_test "gu i" "\[0-9\]+"
  67     gdb_test "gu (history-ref i)" "#<gdb:value 42>"
  68     gdb_test "p \$" "= 42"
  69
  70     # Test dereferencing the argv pointer.
  71
  72     # Just get inferior variable argv the value history, available to guile.
  73     gdb_test "print argv" "= \\(char \\*\\*\\) 0x.*" ""
  74
  75     gdb_scm_test_silent_cmd "gu (define argv (history-ref 0))" \
  76         "set argv"
  77     gdb_scm_test_silent_cmd "gu (define arg0 (value-dereference argv))" \
  78         "set arg0"
  79
  80     # Check that the dereferenced value is sane.
  81     if { ! [target_info exists noargs] } {
  82         gdb_test "gu (print arg0)" \
  83             "0x.*$testfile\"" "verify dereferenced value"
  84     }
  85
  86     # Smoke-test value-optimized-out?.
  87     gdb_test "gu (print (value-optimized-out? arg0))" \
  88         "= #f" "Test value-optimized-out?"
  89
  90     # Test address attribute.
  91     gdb_test "gu (print (value-address arg0))" \
  92         "= 0x\[\[:xdigit:\]\]+" "Test address attribute"
  93     # Test address attribute is #f in a non-addressable value.
  94     gdb_test "gu (print (value-address (make-value 42)))" \
  95         "= #f" "Test address attribute in non-addressable value"
  96
  97     # Test displaying a variable that is temporarily at a bad address.
  98     # But if we can examine what's at memory address 0, then we'll also be
  99     # able to display it without error.  Don't run the test in that case.
 100     set can_read_0 0
 101     gdb_test_multiple "x 0" "memory at address 0" {
 102         -re "0x0:\[ \t\]*Cannot access memory at address 0x0\r\n$gdb_prompt $" { }
 103         -re "0x0:\[ \t\]*Error accessing memory address 0x0\r\n$gdb_prompt $" { }
 104         -re "\r\n$gdb_prompt $" {
 105             set can_read_0 1
 106         }
 107     }
 108
 109     # Test memory error.
 110     set test "parse_and_eval with memory error"
 111     if {$can_read_0} {
 112         untested $test
 113     } else {
 114         gdb_test "gu (print (parse-and-eval \"*(int*)0\"))" \
 115             "ERROR: Cannot access memory at address 0x0.*" $test
 116     }
 117
 118     # Test Guile lazy value handling
 119     set test "memory error and lazy values"
 120     if {$can_read_0} {
 121         untested $test
 122     } else {
 123         gdb_test_no_output "gu (define inval (parse-and-eval \"*(int*)0\"))"
 124         gdb_test "gu (print (value-lazy? inval))" \
 125             "#t"
 126         gdb_test "gu (define inval2 (value-add inval 1))" \
 127             "ERROR: Cannot access memory at address 0x0.*" $test
 128         gdb_test "gu (value-fetch-lazy! inval))" \
 129             "ERROR: Cannot access memory at address 0x0.*" $test
 130     }
 131     gdb_test_no_output "gu (define argc-lazy (parse-and-eval \"argc\"))"
 132     gdb_test_no_output "gu (define argc-notlazy (parse-and-eval \"argc\"))"
 133     gdb_test_no_output "gu (value-fetch-lazy! argc-notlazy)"
 134     gdb_test "gu (print (value-lazy? argc-lazy))" "= #t"
 135     gdb_test "gu (print (value-lazy? argc-notlazy))" "= #f"
 136     gdb_test "print argc" "= 1" "sanity check argc"
 137     gdb_test "gu (print (value-lazy? argc-lazy))" "= #t"
 138     gdb_test_no_output "set argc=2"
 139     gdb_test "gu (print argc-notlazy)" "= 1"
 140     gdb_test "gu (print argc-lazy)" "= 2"
 141     gdb_test "gu (print (value-lazy? argc-lazy))" "= #f"
 142
 143     # Test string fetches, both partial and whole.
 144     gdb_test "print st" "\"divide et impera\""
 145     gdb_scm_test_silent_cmd "gu (define st (history-ref 0))" \
 146         "inf: get st value from history"
 147     gdb_test "gu (print (value->string st))" \
 148         "= divide et impera"  "Test string with no length"
 149     gdb_test "gu (print (value->string st #:length -1))" \
 150         "= divide et impera" "Test string (length = -1) is all of the string"
 151     gdb_test "gu (print (value->string st #:length 6))" \
 152         "= divide"
 153     gdb_test "gu (print (string-append \"---\" (value->string st #:length 0) \"---\"))" \
 154         "= ------" "Test string (length = 0) is empty"
 155     gdb_test "gu (print (string-length (value->string st #:length 0)))" \
 156         "= 0" "Test length is 0"
 157
 158     # Fetch a string that has embedded nulls.
 159     gdb_test "print nullst" "\"divide\\\\000et\\\\000impera\".*"
 160     gdb_scm_test_silent_cmd "gu (define nullst (history-ref 0))" \
 161         "inf: get nullst value from history"
 162     gdb_test "gu (print (value->string nullst))" \
 163         "divide" "Test string to first null"
 164     gdb_scm_test_silent_cmd "gu (set! nullst (value->string nullst #:length 9))" \
 165         "get string beyond null"
 166     gdb_test "gu (print nullst)" \
 167         "= divide\\\\000et"
 168 }
 169
 170 proc test_strings {} {
 171     gdb_test "gu (make-value \"test\")" "#<gdb:value \"test\">" "make string"
 172
 173     # Test string conversion errors.
 174     set save_charset [get_target_charset]
 175     gdb_test_no_output "set target-charset UTF-8"
 176
 177     gdb_test_no_output "gu (set-port-conversion-strategy! #f 'error)"
 178     gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\"))" \
 179         "ERROR.*decoding-error.*" \
 180         "value->string with default #:errors = 'error"
 181
 182     # There is no 'escape strategy for C->SCM string conversions, but it's
 183     # still a legitimate value for %default-port-conversion-strategy.
 184     # GDB handles this by, umm, substituting 'substitute.
 185     # Use this case to also handle "#:errors #f" which explicitly says
 186     # "use %default-port-conversion-strategy".
 187     gdb_test_no_output "gu (set-port-conversion-strategy! #f 'escape)"
 188     gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors #f))" \
 189         "= \[?\]{3}" "value->string with default #:errors = 'escape"
 190
 191     # This is last in the default conversion tests so that
 192     # %default-port-conversion-strategy ends up with the default value.
 193     gdb_test_no_output "gu (set-port-conversion-strategy! #f 'substitute)"
 194     gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\"))" \
 195         "= \[?\]{3}" "value->string with default #:errors = 'substitute"
 196
 197     gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors 'error))" \
 198         "ERROR.*decoding-error.*" "value->string #:errors 'error"
 199     gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors 'substitute))" \
 200         "= \[?\]{3}" "value->string #:errors 'substitute"
 201     gdb_test "gu (print (value->string (make-value \"abc\") #:errors \"foo\"))" \
 202         "ERROR.*invalid error kind.*" "bad value for #:errors"
 203
 204     gdb_test_no_output "set target-charset $save_charset" \
 205         "restore target-charset"
 206 }
 207
 208 proc test_lazy_strings {} {
 209     global hex
 210
 211     gdb_test "print sptr" "\"pointer\""
 212     gdb_scm_test_silent_cmd "gu (define sptr (history-ref 0))" \
 213         "lazy strings: get sptr value from history"
 214
 215     gdb_scm_test_silent_cmd "gu (define lstr (value->lazy-string sptr))" \
 216         "Aquire lazy string"
 217     gdb_test "gu (print (lazy-string-type lstr))" \
 218         "= const char \*." "Test lazy-string type name equality"
 219     gdb_test "gu (print (value-type sptr))" \
 220         "= const char \*." "Test string type name equality"
 221     gdb_test "print sn" "0x0"
 222     gdb_scm_test_silent_cmd "gu (define snptr (history-ref 0))" \
 223         "lazy strings: get snptr value from history"
 224     gdb_test "gu (define snstr (value->lazy-string snptr #:length 5))" \
 225         ".*cannot create a lazy string with address.*" "Test lazy string"
 226     gdb_scm_test_silent_cmd "gu (define snstr (value->lazy-string snptr #:length 0))" \
 227         "Successfully create a lazy string"
 228     gdb_test "gu (print (lazy-string-length snstr))" \
 229         "= 0" "Test lazy string length"
 230     gdb_test "gu (print (lazy-string-address snstr))" \
 231         "= 0" "Test lazy string address"
 232 }
 233
 234 proc test_inferior_function_call {} {
 235     global gdb_prompt hex decimal
 236
 237     # Correct inferior call without arguments.
 238     gdb_test "p/x fp1" "= $hex.*"
 239     gdb_scm_test_silent_cmd "gu (define fp1 (history-ref 0))" \
 240         "get fp1 value from history"
 241     gdb_scm_test_silent_cmd "gu (set! fp1 (value-dereference fp1))" \
 242         "dereference fp1"
 243     gdb_test "gu (print (value-call fp1 '()))" \
 244         "= void"
 245
 246     # Correct inferior call with arguments.
 247     gdb_test "p/x fp2" "= $hex.*"
 248     gdb_scm_test_silent_cmd "gu (define fp2 (history-ref 0))" \
 249         "get fp2 value from history"
 250     gdb_scm_test_silent_cmd "gu (set! fp2 (value-dereference fp2))" \
 251         "dereference fp2"
 252     gdb_test "gu (print (value-call fp2 (list 10 20)))" \
 253         "= 30"
 254
 255     # Incorrect to call an int value.
 256     gdb_test "p i" "= $decimal.*"
 257     gdb_scm_test_silent_cmd "gu (define i (history-ref 0))" \
 258         "inf call: get i value from history"
 259     gdb_test "gu (print (value-call i '()))" \
 260         "ERROR: .*: Wrong type argument in position 1 \\(expecting function \\(value of TYPE_CODE_FUNC\\)\\): .*"
 261
 262     # Incorrect number of arguments.
 263     gdb_test "p/x fp2" "= $hex.*"
 264     gdb_scm_test_silent_cmd "gu (define fp3 (history-ref 0))" \
 265         "get fp3 value from history"
 266     gdb_scm_test_silent_cmd "gu (set! fp3 (value-dereference fp3))" \
 267         "dereference fp3"
 268     gdb_test "gu (print (value-call fp3 (list 10)))" \
 269         "ERROR: Too few arguments in function call.*"
 270 }
 271
 272 proc test_value_after_death {} {
 273     # Construct a type while the inferior is still running.
 274     gdb_scm_test_silent_cmd "gu (define ptrtype (lookup-type \"PTR\"))" \
 275         "create PTR type"
 276
 277     # Kill the inferior and remove the symbols.
 278     gdb_test "kill" "" "kill the inferior" \
 279         "Kill the program being debugged. .y or n. $" \
 280         "y"
 281     gdb_test "file" "" "Discard the symbols" \
 282         "Discard symbol table from.*y or n. $" \
 283         "y"
 284
 285     # Now create a value using that type.  Relies on arg0, created by
 286     # test_value_in_inferior.
 287     gdb_scm_test_silent_cmd "gu (define castval (value-cast arg0 (type-pointer ptrtype)))" \
 288         "cast arg0 to PTR"
 289
 290     # Make sure the type is deleted.
 291     gdb_scm_test_silent_cmd "gu (set! ptrtype #f)" \
 292         "delete PTR type"
 293
 294     # Now see if the value's type is still valid.
 295     gdb_test "gu (print (value-type castval))" \
 296         "= PTR ." "print value's type"
 297 }
 298
 299 # Regression test for invalid subscript operations.  The bug was that
 300 # the type of the value was not being checked before allowing a
 301 # subscript operation to proceed.
 302
 303 proc test_subscript_regression {exefile lang} {
 304     # Start with a fresh gdb.
 305     clean_restart ${exefile}
 306
 307     if ![gdb_guile_runto_main ] {
 308         fail "Can't run to main"
 309         return
 310     }
 311
 312     if {$lang == "c++"} {
 313         gdb_breakpoint [gdb_get_line_number "break to inspect pointer by reference"]
 314         gdb_continue_to_breakpoint "break to inspect pointer by reference"
 315
 316         gdb_scm_test_silent_cmd "print rptr_int" \
 317             "Obtain address"
 318         gdb_scm_test_silent_cmd "gu (define rptr (history-ref 0))" \
 319             "set rptr"
 320         gdb_test "gu (print (value-subscript rptr 0))" \
 321             "= 2" "Check pointer passed as reference"
 322
 323         # Just the most basic test of dynamic_cast -- it is checked in
 324         # the C++ tests.
 325         gdb_test "gu (print (value->bool (value-dynamic-cast (parse-and-eval \"base\") (type-pointer (lookup-type \"Derived\")))))" \
 326             "= #t"
 327
 328         # Likewise.
 329         gdb_test "gu (print (value-dynamic-type (parse-and-eval \"base\")))" \
 330             "= Derived \[*\]"
 331         # A static type case.
 332         gdb_test "gu (print (value-dynamic-type (parse-and-eval \"5\")))" \
 333             "= int"
 334     }
 335
 336     gdb_breakpoint [gdb_get_line_number "break to inspect struct and union"]
 337     gdb_continue_to_breakpoint "break to inspect struct and union"
 338
 339     gdb_scm_test_silent_cmd "gu (define intv (make-value 1))" \
 340         "Create int value for subscript test"
 341     gdb_scm_test_silent_cmd "gu (define stringv (make-value \"foo\"))" \
 342         "Create string value for subscript test"
 343
 344     # Try to access an int with a subscript.  This should fail.
 345     gdb_test "gu (print intv)" \
 346         "= 1" "Baseline print of an int Guile value"
 347     gdb_test "gu (print (value-subscript intv 0))" \
 348         "ERROR: Cannot subscript requested type.*" \
 349         "Attempt to access an integer with a subscript"
 350
 351     # Try to access a string with a subscript.  This should pass.
 352     gdb_test "gu (print stringv)" \
 353         "= \"foo\"" "Baseline print of a string Guile value"
 354     gdb_test "gu (print (value-subscript stringv 0))" \
 355         "= 102 'f'" "Attempt to access a string with a subscript"
 356
 357     # Try to access an int array via a pointer with a subscript.
 358     # This should pass.
 359     gdb_scm_test_silent_cmd "print p" "Build pointer to array"
 360     gdb_scm_test_silent_cmd "gu (define pointer (history-ref 0))" "set pointer"
 361     gdb_test "gu (print (value-subscript pointer 0))" \
 362         "= 1" "Access array via pointer with int subscript"
 363     gdb_test "gu (print (value-subscript pointer intv))" \
 364         "= 2" "Access array via pointer with value subscript"
 365
 366     # Try to access a single dimension array with a subscript to the
 367     # result.  This should fail.
 368     gdb_test "gu (print (value-subscript (value-subscript pointer intv) 0))" \
 369         "ERROR: Cannot subscript requested type.*" \
 370         "Attempt to access an integer with a subscript 2"
 371
 372     # Lastly, test subscript access to an array with multiple
 373     # dimensions.  This should pass.
 374     gdb_scm_test_silent_cmd "print {\"fu \",\"foo\",\"bar\"}" "Build array"
 375     gdb_scm_test_silent_cmd "gu (define marray (history-ref 0))" ""
 376     gdb_test "gu (print (value-subscript (value-subscript marray 1) 2))" \
 377         "o." "Test multiple subscript"
 378 }
 379
 380 # A few tests of gdb:parse-and-eval.
 381
 382 proc test_parse_and_eval {} {
 383     gdb_test "gu (print (parse-and-eval \"23\"))" \
 384         "= 23" "parse-and-eval constant test"
 385     gdb_test "gu (print (parse-and-eval \"5 + 7\"))" \
 386         "= 12" "parse-and-eval simple expression test"
 387     gdb_test "gu (raw-print (parse-and-eval \"5 + 7\"))" \
 388         "#<gdb:value 12>" "parse-and-eval type test"
 389 }
 390
 391 # Test that values are hashable.
 392 # N.B.: While smobs are hashable, the hash is really non-existent,
 393 # they all get hashed to the same value.  Guile may provide a hash function
 394 # for smobs in a future release.  In the meantime one should use a custom
 395 # hash table that uses gdb:hash-gsmob.
 396
 397 proc test_value_hash {} {
 398     gdb_test_multiline "Simple Guile value dictionary" \
 399         "guile" "" \
 400         "(define one (make-value 1))" "" \
 401         "(define two (make-value 2))" "" \
 402         "(define three (make-value 3))" "" \
 403         "(define vdict (make-hash-table 5))" "" \
 404         "(hash-set! vdict one \"one str\")" "" \
 405         "(hash-set! vdict two \"two str\")" "" \
 406         "(hash-set! vdict three \"three str\")" "" \
 407         "end"
 408     gdb_test "gu (print (hash-ref vdict one))" \
 409         "one str" "Test dictionary hash 1"
 410     gdb_test "gu (print (hash-ref vdict two))" \
 411         "two str" "Test dictionary hash 2"
 412     gdb_test "gu (print (hash-ref vdict three))" \
 413         "three str" "Test dictionary hash 3"
 414 }
 415
 416 # Build C version of executable.  C++ is built later.
 417 if { [build_inferior "${binfile}" "c"] < 0 } {
 418     return
 419 }
 420
 421 # Start with a fresh gdb.
 422 clean_restart ${binfile}
 423
 424 # Skip all tests if Guile scripting is not enabled.
 425 if { [skip_guile_tests] } { continue }
 426
 427 gdb_install_guile_utils
 428 gdb_install_guile_module
 429
 430 test_parse_and_eval
 431 test_value_hash
 432
 433 # The following tests require execution.
 434
 435 if ![gdb_guile_runto_main] {
 436     fail "Can't run to main"
 437     return
 438 }
 439
 440 test_value_in_inferior
 441 test_inferior_function_call
 442 test_strings
 443 test_lazy_strings
 444 test_value_after_death
 445
 446 # Test either C or C++ values.
 447
 448 test_subscript_regression "${binfile}" "c"
 449
 450 if ![skip_cplus_tests] {
 451     if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
 452         return
 453     }
 454     with_test_prefix "c++" {
 455         test_subscript_regression "${binfile}-cxx" "c++"
 456     }
 457 }