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

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