1 ;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
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.
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.
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/>.
16 ;; This file is part of the GDB testsuite.
17 ;; It tests Scheme pretty printers.
19 (use-modules (gdb) (gdb printing))
21 (define (make-pointer-iterator pointer len)
22 (let ((next! (lambda (iter)
23 (let* ((start (iterator-object iter))
24 (progress (iterator-progress iter))
25 (current (car progress))
29 (let ((pointer (value-add start current)))
30 (set-car! progress (+ current 1))
31 (cons (format #f "[~A]" current)
32 (value-dereference pointer))))))))
33 (make-iterator pointer (cons 0 len) next!)))
35 (define (make-pointer-iterator-except pointer len)
36 (let ((next! (lambda (iter)
38 (throw 'gdb:memory-error "hi bob"))
39 (let* ((start (iterator-object iter))
40 (progress (iterator-progress iter))
41 (current (car progress))
45 (let ((pointer (value-add start current)))
46 (set-car! progress (+ current 1))
47 (cons (format #f "[~A]" current)
48 (value-dereference pointer))))))))
49 (make-iterator pointer (cons 0 len) next!)))
51 ;; Test returning a <gdb:value> from a printer.
53 (define (make-string-printer val)
54 (make-pretty-printer-worker
57 (value-field (value-field val "whybother")
61 ;; Test a printer with children.
63 (define (make-container-printer val)
64 ;; This is a little different than the Python version in that if there's
65 ;; an error accessing these fields we'll throw it at matcher time instead
66 ;; of at printer time. Done this way to explore the possibilities.
67 (let ((name (value-field val "name"))
68 (len (value-field val "len"))
69 (elements (value-field val "elements")))
70 (make-pretty-printer-worker
73 (format #f "container ~A with ~A elements"
76 (make-pointer-iterator elements (value->integer len))))))
78 ;; Test "array" display hint.
80 (define (make-array-printer val)
81 (let ((name (value-field val "name"))
82 (len (value-field val "len"))
83 (elements (value-field val "elements")))
84 (make-pretty-printer-worker
87 (format #f "array ~A with ~A elements"
90 (make-pointer-iterator elements (value->integer len))))))
92 ;; Flag to make no-string-container printer throw an exception.
94 (define *exception-flag* #f)
96 ;; Test a printer where to_string returns #f.
98 (define (make-no-string-container-printer val)
99 (let ((len (value-field val "len"))
100 (elements (value-field val "elements")))
101 (make-pretty-printer-worker
103 (lambda (printer) #f)
105 (make-pointer-iterator-except elements (value->integer len))))))
107 (define (make-pp_s-printer val)
108 (make-pretty-printer-worker
111 (let ((a (value-field val "a"))
112 (b (value-field val "b")))
113 (if (not (value=? (value-address a) b))
114 (error (format #f "&a(~A) != b(~A)"
115 (value-address a) b)))
116 (format #f "a=<~A> b=<~A>" a b)))
119 (define (make-pp_ss-printer val)
120 (make-pretty-printer-worker
123 (let ((a (value-field val "a"))
124 (b (value-field val "b")))
125 (format #f "a=<~A> b=<~A>" a b)))
128 (define (make-pp_sss-printer val)
129 (make-pretty-printer-worker
132 (let ((a (value-field val "a"))
133 (b (value-field val "b")))
134 (format #f "a=<~A> b=<~A>" a b)))
137 (define (make-pp_multiple_virtual-printer val)
138 (make-pretty-printer-worker
141 (format #f "pp value variable is: ~A" (value-field val "value")))
144 (define (make-pp_vbase1-printer val)
145 (make-pretty-printer-worker
148 (format #f "pp class name: ~A" (type-tag (value-type val))))
151 (define (make-pp_nullstr-printer val)
152 (make-pretty-printer-worker
155 (value->string (value-field val "s")
156 #:encoding (arch-charset (current-arch))))
159 (define (make-pp_ns-printer val)
160 (make-pretty-printer-worker
163 (let ((len (value-field val "length")))
164 (value->string (value-field val "null_str")
165 #:encoding (arch-charset (current-arch))
166 #:length (value->integer len))))
169 (define *pp-ls-encoding* #f)
171 (define (make-pp_ls-printer val)
172 (make-pretty-printer-worker
176 (value->lazy-string (value-field val "lazy_str")
177 #:encoding *pp-ls-encoding*)
178 (value->lazy-string (value-field val "lazy_str"))))
181 (define (make-pp_hint_error-printer val)
182 "Use an invalid value for the display hint."
183 (make-pretty-printer-worker
185 (lambda (printer) "hint_error_val")
188 (define (make-pp_children_as_list-printer val)
189 (make-pretty-printer-worker
191 (lambda (printer) "children_as_list_val")
192 (lambda (printer) (make-list-iterator (list (cons "one" 1))))))
194 (define (make-pp_outer-printer val)
195 (make-pretty-printer-worker
198 (format #f "x = ~A" (value-field val "x")))
200 (make-list-iterator (list (cons "s" (value-field val "s"))
201 (cons "x" (value-field val "x")))))))
203 (define (make-memory-error-string-printer val)
204 (make-pretty-printer-worker
207 (scm-error 'gdb:memory-error "memory-error-printer"
208 "Cannot access memory." '() '()))
211 (define (make-pp_eval_type-printer val)
212 (make-pretty-printer-worker
215 (execute "bt" #:to-string #t)
216 (format #f "eval=<~A>"
219 "eval_func (123456789, 2, 3, 4, 5, 6, 7, 8)"))))
222 (define (get-type-for-printing val)
223 "Return type of val, stripping away typedefs, etc."
224 (let ((type (value-type val)))
225 (if (= (type-code type) TYPE_CODE_REF)
226 (set! type (type-target type)))
227 (type-strip-typedefs (type-unqualified type))))
229 (define (disable-matcher!)
230 (set-pretty-printer-enabled! *pretty-printer* #f))
232 (define (enable-matcher!)
233 (set-pretty-printer-enabled! *pretty-printer* #t))
235 (define (make-pretty-printer-dict)
236 (let ((dict (make-hash-table)))
237 (hash-set! dict "struct s" make-pp_s-printer)
238 (hash-set! dict "s" make-pp_s-printer)
239 (hash-set! dict "S" make-pp_s-printer)
241 (hash-set! dict "struct ss" make-pp_ss-printer)
242 (hash-set! dict "ss" make-pp_ss-printer)
243 (hash-set! dict "const S &" make-pp_s-printer)
244 (hash-set! dict "SSS" make-pp_sss-printer)
246 (hash-set! dict "VirtualTest" make-pp_multiple_virtual-printer)
247 (hash-set! dict "Vbase1" make-pp_vbase1-printer)
249 (hash-set! dict "struct nullstr" make-pp_nullstr-printer)
250 (hash-set! dict "nullstr" make-pp_nullstr-printer)
252 ;; Note that we purposely omit the typedef names here.
253 ;; Printer lookup is based on canonical name.
254 ;; However, we do need both tagged and untagged variants, to handle
255 ;; both the C and C++ cases.
256 (hash-set! dict "struct string_repr" make-string-printer)
257 (hash-set! dict "struct container" make-container-printer)
258 (hash-set! dict "struct justchildren" make-no-string-container-printer)
259 (hash-set! dict "string_repr" make-string-printer)
260 (hash-set! dict "container" make-container-printer)
261 (hash-set! dict "justchildren" make-no-string-container-printer)
263 (hash-set! dict "struct ns" make-pp_ns-printer)
264 (hash-set! dict "ns" make-pp_ns-printer)
266 (hash-set! dict "struct lazystring" make-pp_ls-printer)
267 (hash-set! dict "lazystring" make-pp_ls-printer)
269 (hash-set! dict "struct outerstruct" make-pp_outer-printer)
270 (hash-set! dict "outerstruct" make-pp_outer-printer)
272 (hash-set! dict "struct hint_error" make-pp_hint_error-printer)
273 (hash-set! dict "hint_error" make-pp_hint_error-printer)
275 (hash-set! dict "struct children_as_list"
276 make-pp_children_as_list-printer)
277 (hash-set! dict "children_as_list" make-pp_children_as_list-printer)
279 (hash-set! dict "memory_error" make-memory-error-string-printer)
281 (hash-set! dict "eval_type_s" make-pp_eval_type-printer)
285 ;; This is one way to register a printer that is composed of several
286 ;; subprinters, but there's no way to disable or list individual subprinters.
288 (define *pretty-printer*
290 "pretty-printer-test"
291 (let ((pretty-printers-dict (make-pretty-printer-dict)))
292 (lambda (matcher val)
293 "Look-up and return a pretty-printer that can print val."
294 (let ((type (get-type-for-printing val)))
295 (let ((typename (type-tag type)))
297 (let ((printer-maker (hash-ref pretty-printers-dict typename)))
298 (and printer-maker (printer-maker val)))
301 (append-pretty-printer! #f *pretty-printer*)