]>
Commit | Line | Data |
---|---|---|
213516ef | 1 | # Copyright (C) 2010-2023 Free Software Foundation, Inc. |
06eb1586 DE |
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 | ||
90319cef MR |
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 | ||
06eb1586 | 40 | # We use "." here instead of ":" so that this works on win32 too. |
2631b16a AW |
41 | set escaped_directory [string_to_regexp "$srcdir/$subdir"] |
42 | gdb_test "guile (print (parameter-value \"directories\"))" "$escaped_directory.\\\$cdir.\\\$cwd" | |
06eb1586 DE |
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)" | |
cdc7edd7 | 63 | gdb_test "show print test-param" "The state of the Test Parameter is on." "show parameter on" |
06eb1586 | 64 | gdb_test_no_output "set print test-param off" |
cdc7edd7 | 65 | gdb_test "show print test-param" "The state of the Test Parameter is off." "show parameter off" |
06eb1586 DE |
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 | ||
90319cef MR |
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 \ | |
ee7f721e SM |
186 | [multi_line \ |
187 | "ERROR: In procedure set-parameter-value!:" \ | |
4404bce9 MR |
188 | "(ERROR: )?In procedure gdbscm_set_parameter_value_x:\ |
189 | Wrong type argument in position 2 \\(expecting integer\\):\ | |
190 | #:unlimited" \ | |
ee7f721e | 191 | "Error while executing Scheme code\\."] |
90319cef MR |
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 | ||
06eb1586 DE |
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" { | |
62f2f198 AB |
340 | gdb_test "show test-restricted-param" "The value of the restricted parameter is 2." \ |
341 | "test-restricted-param is initially 2" | |
06eb1586 | 342 | gdb_test_no_output "set test-restricted-param 10" |
62f2f198 AB |
343 | gdb_test "show test-restricted-param" "The value of the restricted parameter is 10." \ |
344 | "test-restricted-param is now 10" | |
06eb1586 | 345 | gdb_test "set test-restricted-param 42" "Error: Range of parameter is 0-10." |
62f2f198 AB |
346 | gdb_test "show test-restricted-param" "The value of the restricted parameter is 2." \ |
347 | "test-restricted-param is back to 2 again" | |
06eb1586 | 348 | } |
7ebdbe92 DE |
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 | ||
3e1e8561 SM |
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 | ||
7ebdbe92 DE |
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)" | |
cdc7edd7 | 377 | gdb_test "show print s" "Command is not documented is off." "show parameter off" |
7ebdbe92 | 378 | gdb_test_no_output "set print s on" |
cdc7edd7 | 379 | gdb_test "show print s" "Command is not documented is on." "show parameter on" |
7ebdbe92 DE |
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 | } | |
90319cef MR |
385 | |
386 | rename scm_param_test_maybe_no_output "" |