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 19load_lib gdb-guile.exp 20 21# Start with a fresh gdb. 22gdb_exit 23gdb_start 24gdb_reinitialize_dir $srcdir/$subdir 25 26# Skip all tests if Guile scripting is not enabled. 27if { [skip_guile_tests] } { continue } 28 29gdb_install_guile_utils 30gdb_install_guile_module 31 32proc 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. 41set escaped_directory [string_to_regexp "$srcdir/$subdir"] 42gdb_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 46gdb_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 61with_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 77gdb_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 93with_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 104foreach_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 164foreach_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 272gdb_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 287with_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 298gdb_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 308with_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 320gdb_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 339with_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 352gdb_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. 356gdb_test "guile (print (parameter-value (make-parameter \"foo\")))" \ 357 "= #f" 358gdb_test "guile (define myparam (make-parameter \"foo\"))" 359gdb_test_no_output "guile (set-parameter-value! myparam #t)" 360gdb_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 366gdb_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 373gdb_test_no_output "guile (register-parameter! prev-ambig)" 374 375with_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 386rename scm_param_test_maybe_no_output "" 387