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

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