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

   1 # Copyright (C) 2010-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 GDB parameter support in Guile.
  18
  19 load_lib gdb-guile.exp
  20
  21 require allow_guile_tests
  22
  23 clean_restart
  24
  25 gdb_install_guile_utils
  26 gdb_install_guile_module
  27
  28 proc scm_param_test_maybe_no_output { command pattern args } {
  29     if [string length $pattern] {
  30         gdb_test $command $pattern $args
  31     } else {
  32         gdb_test_no_output $command $args
  33     }
  34 }
  35
  36 # We use "." here instead of ":" so that this works on win32 too.
  37 if { [is_remote host] } {
  38     # Proc gdb_reinitialize_dir has no effect for remote host.
  39     gdb_test "guile (print (parameter-value \"directories\"))" \
  40         "\\\$cdir.\\\$cwd"
  41 } else {
  42     set escaped_directory [string_to_regexp "$srcdir/$subdir"]
  43     gdb_test "guile (print (parameter-value \"directories\"))" \
  44         "$escaped_directory.\\\$cdir.\\\$cwd"
  45 }
  46
  47 # Test a simple boolean parameter, and parameter? while we're at it.
  48
  49 gdb_test_multiline "Simple gdb boolean parameter" \
  50     "guile" "" \
  51     "(define test-param" "" \
  52     "  (make-parameter \"print test-param\"" "" \
  53     "   #:command-class COMMAND_DATA" "" \
  54     "   #:parameter-type PARAM_BOOLEAN" "" \
  55     "   #:doc \"When enabled, test param does something useful. When disabled, does nothing.\"" "" \
  56     "   #:set-doc \"Set the state of the boolean test-param.\"" "" \
  57     "   #:show-doc \"Show the state of the boolean test-param.\"" "" \
  58     "   #:show-func (lambda (self value)" ""\
  59     "      (format #f \"The state of the Test Parameter is ~a.\" value))" "" \
  60     "   #:initial-value #t))" "" \
  61     "(register-parameter! test-param)" "" \
  62     "end"
  63
  64 with_test_prefix "test-param" {
  65     gdb_test "guile (print (parameter-value test-param))" "= #t" "parameter value, true"
  66     gdb_test "show print test-param" "The state of the Test Parameter is on." "show parameter on"
  67     gdb_test_no_output "set print test-param off"
  68     gdb_test "show print test-param" "The state of the Test Parameter is off." "show parameter off"
  69     gdb_test "guile (print (parameter-value test-param))" "= #f" "parameter value, false"
  70     gdb_test "help show print test-param" "Show the state of the boolean test-param.*" "show help"
  71     gdb_test "help set print test-param" "Set the state of the boolean test-param.*" "set help"
  72     gdb_test "help set print" "set print test-param -- Set the state of the boolean test-param.*" "general help"
  73
  74     gdb_test "guile (print (parameter? test-param))" "= #t"
  75     gdb_test "guile (print (parameter? 42))" "= #f"
  76 }
  77
  78 # Test an enum parameter.
  79
  80 gdb_test_multiline "enum gdb parameter" \
  81     "guile" "" \
  82     "(define test-enum-param" "" \
  83     "  (make-parameter \"print test-enum-param\"" "" \
  84     "   #:command-class COMMAND_DATA" "" \
  85     "   #:parameter-type PARAM_ENUM" "" \
  86     "   #:enum-list '(\"one\" \"two\")" "" \
  87     "   #:doc \"When set, test param does something useful. When disabled, does nothing.\"" "" \
  88     "   #:show-doc \"Show the state of the enum.\"" "" \
  89     "   #:set-doc \"Set the state of the enum.\"" "" \
  90     "   #:show-func (lambda (self value)" "" \
  91     "      (format #f \"The state of the enum is ~a.\" value))" "" \
  92     "   #:initial-value \"one\"))" "" \
  93     "(register-parameter! test-enum-param)" "" \
  94     "end"
  95
  96 with_test_prefix "test-enum-param" {
  97     gdb_test "guile (print (parameter-value test-enum-param))" "one" "enum parameter value, one"
  98     gdb_test "show print test-enum-param" "The state of the enum is one." "show initial value"
  99     gdb_test_no_output "set print test-enum-param two"
 100     gdb_test "show print test-enum-param" "The state of the enum is two." "show new value"
 101     gdb_test "guile (print (parameter-value test-enum-param))" "two" "enum parameter value, two"
 102     gdb_test "set print test-enum-param three" "Undefined item: \"three\".*" "set invalid enum parameter"
 103 }
 104
 105 # Test integer parameters.
 106
 107 foreach_with_prefix param {
 108     "listsize"
 109     "print elements"
 110     "max-completions"
 111     "print characters"
 112 } {
 113     set param_range_error "integer -1 out of range"
 114     set param_type_error \
 115         "#<gdb:exception out-of-range\
 116          \\(\"gdbscm_parameter_value\"\
 117             \"Out of range: program error: unhandled type in position 1: ~S\"\
 118             \\(3\\) \\(3\\)\\)>"
 119     switch -- $param {
 120         "listsize" {
 121             set param_get_zero "#:unlimited"
 122             set param_get_minus_one -1
 123             set param_set_minus_one ""
 124         }
 125         "print elements" -
 126         "print characters" {
 127             set param_get_zero "#:unlimited"
 128             set param_get_minus_one "#:unlimited"
 129             set param_set_minus_one $param_range_error
 130         }
 131         "max-completions" {
 132             set param_get_zero 0
 133             set param_get_minus_one "#:unlimited"
 134             set param_set_minus_one ""
 135         }
 136         default {
 137             error "invalid param: $param"
 138         }
 139     }
 140
 141     gdb_test_no_output "set $param 1" "test set to 1"
 142
 143     gdb_test "guile (print (parameter-value \"$param\"))" \
 144         1 "test value of 1"
 145
 146     gdb_test_no_output "set $param 0" "test set to 0"
 147
 148     gdb_test "guile (print (parameter-value \"$param\"))" \
 149         $param_get_zero "test value of 0"
 150
 151     scm_param_test_maybe_no_output "set $param -1" \
 152         $param_set_minus_one "test set to -1"
 153
 154     gdb_test "guile (print (parameter-value \"$param\"))" \
 155         $param_get_minus_one "test value of -1"
 156
 157     gdb_test_no_output "set $param unlimited" "test set to 'unlimited'"
 158
 159     gdb_test "guile (print (parameter-value \"$param\"))" \
 160         "#:unlimited" "test value of 'unlimited'"
 161
 162     if {$param == "print characters"} {
 163         gdb_test_no_output "set $param elements" "test set to 'elements'"
 164
 165         gdb_test "guile (print (parameter-value \"$param\"))" \
 166             "#:elements" "test value of 'elements'"
 167     }
 168 }
 169
 170 foreach_with_prefix kind {
 171     PARAM_UINTEGER
 172     PARAM_ZINTEGER
 173     PARAM_ZUINTEGER
 174     PARAM_ZUINTEGER_UNLIMITED
 175 } {
 176     gdb_test_multiline "create gdb parameter" \
 177         "guile" "" \
 178         "(define test-$kind-param" "" \
 179         "  (make-parameter \"print test-$kind-param\"" "" \
 180         "   #:command-class COMMAND_DATA" "" \
 181         "   #:parameter-type $kind" "" \
 182         "   #:doc \"Set to a number or 'unlimited' to yield an effect.\"" "" \
 183         "   #:show-doc \"Show the state of $kind.\"" "" \
 184         "   #:set-doc \"Set the state of $kind.\"" "" \
 185         "   #:show-func (lambda (self value)" "" \
 186         "      (format #f \"The state of $kind is ~a.\" value))" "" \
 187         "   #:initial-value 3))" "" \
 188         "(register-parameter! test-$kind-param)" "" \
 189         "end"
 190
 191     set param_integer_error \
 192         [multi_line \
 193             "ERROR: In procedure set-parameter-value!:" \
 194             "(ERROR: )?In procedure gdbscm_set_parameter_value_x:\
 195              Wrong type argument in position 2 \\(expecting integer\\):\
 196              #:unlimited" \
 197             "Error while executing Scheme code\\."]
 198     set param_minus_one_error "integer -1 out of range"
 199     set param_minus_two_error "integer -2 out of range"
 200     switch -- $kind {
 201         PARAM_UINTEGER {
 202             set param_get_zero "#:unlimited"
 203             set param_get_minus_one "#:unlimited"
 204             set param_get_minus_two "#:unlimited"
 205             set param_str_unlimited unlimited
 206             set param_set_unlimited ""
 207             set param_set_minus_one $param_minus_one_error
 208             set param_set_minus_two $param_minus_two_error
 209         }
 210         PARAM_ZINTEGER {
 211             set param_get_zero 0
 212             set param_get_minus_one -1
 213             set param_get_minus_two -2
 214             set param_str_unlimited 2
 215             set param_set_unlimited $param_integer_error
 216             set param_set_minus_one ""
 217             set param_set_minus_two ""
 218         }
 219         PARAM_ZUINTEGER {
 220             set param_get_zero 0
 221             set param_get_minus_one 0
 222             set param_get_minus_two 0
 223             set param_str_unlimited 2
 224             set param_set_unlimited $param_integer_error
 225             set param_set_minus_one $param_minus_one_error
 226             set param_set_minus_two $param_minus_two_error
 227         }
 228         PARAM_ZUINTEGER_UNLIMITED {
 229             set param_get_zero 0
 230             set param_get_minus_one "#:unlimited"
 231             set param_get_minus_two "#:unlimited"
 232             set param_str_unlimited unlimited
 233             set param_set_unlimited ""
 234             set param_set_minus_one ""
 235             set param_set_minus_two $param_minus_two_error
 236         }
 237         default {
 238             error "invalid kind: $kind"
 239         }
 240     }
 241
 242     with_test_prefix "test-$kind-param" {
 243         gdb_test "guile (print (parameter-value test-$kind-param))" \
 244             3 "$kind parameter value, 3"
 245         gdb_test "show print test-$kind-param" \
 246             "The state of $kind is 3." "show initial value"
 247         gdb_test_no_output "set print test-$kind-param 2"
 248         gdb_test "show print test-$kind-param" \
 249             "The state of $kind is 2." "show new value"
 250         gdb_test "guile (print (parameter-value test-$kind-param))" \
 251             2 "$kind parameter value, 2"
 252         scm_param_test_maybe_no_output \
 253             "guile (set-parameter-value! test-$kind-param #:unlimited)" \
 254             $param_set_unlimited
 255         gdb_test "show print test-$kind-param" \
 256             "The state of $kind is $param_str_unlimited." \
 257             "show unlimited value"
 258         gdb_test_no_output "guile (set-parameter-value! test-$kind-param 1)"
 259         gdb_test "guile (print (parameter-value test-$kind-param))" \
 260             1 "$kind parameter value, 1"
 261         gdb_test_no_output "guile (set-parameter-value! test-$kind-param 0)"
 262         gdb_test "guile (print (parameter-value test-$kind-param))" \
 263             $param_get_zero "$kind parameter value, 0"
 264         scm_param_test_maybe_no_output "set print test-$kind-param -1" \
 265             $param_set_minus_one
 266         gdb_test "guile (print (parameter-value test-$kind-param))" \
 267             $param_get_minus_one "$kind parameter value, -1"
 268         scm_param_test_maybe_no_output "set print test-$kind-param -2" \
 269             $param_set_minus_two
 270         gdb_test "guile (print (parameter-value test-$kind-param))" \
 271             $param_get_minus_two "$kind parameter value, -2"
 272     }
 273 }
 274
 275 # Test a file parameter.
 276
 277 gdb_test_multiline "file gdb parameter" \
 278     "guile" "" \
 279     "(define test-file-param" "" \
 280     "  (make-parameter \"test-file-param\"" "" \
 281     "   #:command-class COMMAND_FILES" "" \
 282     "   #:parameter-type PARAM_FILENAME" "" \
 283     "   #:doc \"When set, test param does something useful. When disabled, does nothing.\"" "" \
 284     "   #:show-doc \"Show the name of the file.\"" "" \
 285     "   #:set-doc \"Set the name of the file.\"" "" \
 286     "   #:show-func (lambda (self value)" "" \
 287     "      (format #f \"The name of the file is ~a.\" value))" "" \
 288     "   #:initial-value \"foo.txt\"))" "" \
 289     "(register-parameter! test-file-param)" "" \
 290     "end"
 291
 292 with_test_prefix "test-file-param" {
 293     gdb_test "guile (print (parameter-value test-file-param))" "foo.txt" "initial parameter value"
 294     gdb_test "show test-file-param" "The name of the file is foo.txt." "show initial value"
 295     gdb_test_no_output "set test-file-param bar.txt"
 296     gdb_test "show test-file-param" "The name of the file is bar.txt." "show new value"
 297     gdb_test "guile (print (parameter-value test-file-param))" "bar.txt" " new parameter value"
 298     gdb_test "set test-file-param" "Argument required.*"
 299 }
 300
 301 # Test a parameter that is not documented.
 302
 303 gdb_test_multiline "undocumented gdb parameter" \
 304     "guile" "" \
 305     "(register-parameter! (make-parameter \"print test-undoc-param\"" "" \
 306     "   #:command-class COMMAND_DATA" "" \
 307     "   #:parameter-type PARAM_BOOLEAN" "" \
 308     "   #:show-func (lambda (self value)" "" \
 309     "      (format #f \"The state of the Test Parameter is ~a.\" value))" "" \
 310     "   #:initial-value #t))" "" \
 311     "end"
 312
 313 with_test_prefix "test-undocumented-param" {
 314     gdb_test "show print test-undoc-param" "The state of the Test Parameter is on." "show parameter on"
 315     gdb_test_no_output "set print test-undoc-param off"
 316     gdb_test "show print test-undoc-param" "The state of the Test Parameter is off." "show parameter off"
 317     gdb_test "help show print test-undoc-param" "This command is not documented." "show help"
 318     gdb_test "help set print test-undoc-param" "This command is not documented." "set help"
 319     gdb_test "help set print" "set print test-undoc-param -- This command is not documented.*" "general help"
 320 }
 321
 322 # Test a parameter with a restricted range, where we need to notify the user
 323 # and restore the previous value.
 324
 325 gdb_test_multiline "restricted gdb parameter" \
 326     "guile" "" \
 327     "(register-parameter! (make-parameter \"test-restricted-param\"" "" \
 328     "   #:command-class COMMAND_DATA" "" \
 329     "   #:parameter-type PARAM_ZINTEGER" "" \
 330     "   #:set-func (lambda (self)" "" \
 331     "      (let ((value (parameter-value self)))" "" \
 332     "        (if (and (>= value 0) (<= value 10))" "" \
 333     "            \"\"" "" \
 334     "            (begin" "" \
 335     "              (set-parameter-value! self (object-property self 'value))" "" \
 336     "              \"Error: Range of parameter is 0-10.\"))))" "" \
 337     "   #:show-func (lambda (self value)" "" \
 338     "      (format #f \"The value of the restricted parameter is ~a.\" value))" "" \
 339     "   #:initial-value (lambda (self)" "" \
 340     "      (set-object-property! self 'value 2)" "" \
 341     "      2)))" "" \
 342     "end"
 343
 344 with_test_prefix "test-restricted-param" {
 345     gdb_test "show test-restricted-param" "The value of the restricted parameter is 2." \
 346         "test-restricted-param is initially 2"
 347     gdb_test_no_output "set test-restricted-param 10"
 348     gdb_test "show test-restricted-param" "The value of the restricted parameter is 10." \
 349         "test-restricted-param is now 10"
 350     gdb_test "set test-restricted-param 42" "Error: Range of parameter is 0-10."
 351     gdb_test "show test-restricted-param" "The value of the restricted parameter is 2." \
 352         "test-restricted-param is back to 2 again"
 353 }
 354
 355 # Test registering a parameter that already exists.
 356
 357 gdb_test "guile (register-parameter! (make-parameter \"height\"))" \
 358     "ERROR.*is already defined.*" "error registering existing parameter"
 359
 360 # Test printing and setting the value of an unregistered parameter.
 361 gdb_test "guile (print (parameter-value (make-parameter \"foo\")))" \
 362     "= #f"
 363 gdb_test "guile (define myparam (make-parameter \"foo\"))"
 364 gdb_test_no_output "guile (set-parameter-value! myparam #t)"
 365 gdb_test "guile (print (parameter-value myparam))" \
 366     "= #t"
 367
 368 # Test registering a parameter named with what was an ambiguous spelling
 369 # of existing parameters.
 370
 371 gdb_test_multiline "previously ambiguously named boolean parameter" \
 372     "guile" "" \
 373     "(define prev-ambig" "" \
 374     "  (make-parameter \"print s\"" "" \
 375     "   #:parameter-type PARAM_BOOLEAN))" "" \
 376     "end"
 377
 378 gdb_test_no_output "guile (register-parameter! prev-ambig)"
 379
 380 with_test_prefix "previously-ambiguous" {
 381     gdb_test "guile (print (parameter-value prev-ambig))" "= #f" "parameter value, false"
 382     gdb_test "show print s" "Command is not documented is off." "show parameter off"
 383     gdb_test_no_output "set print s on"
 384     gdb_test "show print s" "Command is not documented is on." "show parameter on"
 385     gdb_test "guile (print (parameter-value prev-ambig))" "= #t" "parameter value, true"
 386     gdb_test "help show print s" "This command is not documented." "show help"
 387     gdb_test "help set print s" "This command is not documented." "set help"
 388     gdb_test "help set print" "set print s -- This command is not documented.*" "general help"
 389 }
 390
 391 rename scm_param_test_maybe_no_output ""
 392
 393 # Test a color parameter.
 394
 395 with_ansi_styling_terminal {
 396     # This enables 256 colors support and disables colors approximation.
 397     setenv TERM xterm-256color
 398     setenv COLORTERM truecolor
 399
 400     # Start with a fresh gdb.
 401     gdb_exit
 402     gdb_start
 403     gdb_reinitialize_dir $srcdir/$subdir
 404
 405     gdb_install_guile_utils
 406     gdb_install_guile_module
 407
 408     # We use "." here instead of ":" so that this works on win32 too.
 409     set escaped_directory [string_to_regexp "$srcdir/$subdir"]
 410
 411     gdb_test_multiline "color gdb parameter" \
 412         "guile" "" \
 413         "(define test-color-param" "" \
 414         "  (make-parameter \"print test-color-param\"" "" \
 415         "   #:command-class COMMAND_DATA" "" \
 416         "   #:parameter-type PARAM_COLOR" "" \
 417         "   #:doc \"When set, test param does something useful. When disabled, does nothing.\"" "" \
 418         "   #:show-doc \"Show the state of the test-color-param.\"" "" \
 419         "   #:set-doc \"Set the state of the test-color-param.\"" "" \
 420         "   #:show-func (lambda (self value)" "" \
 421         "      (format #f \"The state of the test-color-param is ~a.\" value))" "" \
 422         "   #:initial-value (make-color \"green\")))" "" \
 423         "(register-parameter! test-color-param)" "" \
 424         "end"
 425
 426     with_test_prefix "test-color-param" {
 427         with_test_prefix "initial-value" {
 428             gdb_test "guile (print (parameter-value test-color-param))" "= #<gdb:color green COLORSPACE_ANSI_8COLOR>" "color parameter value (green)"
 429             gdb_test "show print test-color-param" "The state of the test-color-param is green." "show initial value"
 430             gdb_test_no_output "set print test-color-param 255"
 431         }
 432         with_test_prefix "new-value" {
 433             gdb_test "show print test-color-param" "The state of the test-color-param is 255." "show new value"
 434             gdb_test "guile (print (parameter-value test-color-param))" "= #<gdb:color 255 COLORSPACE_XTERM_256COLOR>" "color parameter value (255)"
 435             gdb_test "set print test-color-param 256" "integer 256 out of range.*" "set invalid color parameter"
 436         }
 437     }
 438 }