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

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