Commit | Line | Data |
---|---|---|
b811d2c2 | 1 | ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. |
ed3ef339 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 Scheme pretty printers. | |
18 | ||
19 | (use-modules (gdb) (gdb printing)) | |
20 | ||
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)) | |
26 | (len (cdr progress))) | |
27 | (if (= current len) | |
28 | (end-of-iteration) | |
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!))) | |
34 | ||
35 | (define (make-pointer-iterator-except pointer len) | |
36 | (let ((next! (lambda (iter) | |
37 | (if *exception-flag* | |
38 | (throw 'gdb:memory-error "hi bob")) | |
39 | (let* ((start (iterator-object iter)) | |
40 | (progress (iterator-progress iter)) | |
41 | (current (car progress)) | |
42 | (len (cdr progress))) | |
43 | (if (= current len) | |
44 | (end-of-iteration) | |
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!))) | |
50 | ||
51 | ;; Test returning a <gdb:value> from a printer. | |
52 | ||
53 | (define (make-string-printer val) | |
54 | (make-pretty-printer-worker | |
55 | #f | |
56 | (lambda (printer) | |
57 | (value-field (value-field val "whybother") | |
58 | "contents")) | |
59 | #f)) | |
60 | ||
61 | ;; Test a printer with children. | |
62 | ||
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 | |
71 | #f | |
72 | (lambda (printer) | |
73 | (format #f "container ~A with ~A elements" | |
74 | name len)) | |
75 | (lambda (printer) | |
76 | (make-pointer-iterator elements (value->integer len)))))) | |
77 | ||
78 | ;; Test "array" display hint. | |
79 | ||
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 | |
85 | "array" | |
86 | (lambda (printer) | |
87 | (format #f "array ~A with ~A elements" | |
88 | name len)) | |
89 | (lambda (printer) | |
90 | (make-pointer-iterator elements (value->integer len)))))) | |
91 | ||
92 | ;; Flag to make no-string-container printer throw an exception. | |
93 | ||
94 | (define *exception-flag* #f) | |
95 | ||
96 | ;; Test a printer where to_string returns #f. | |
97 | ||
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 | |
102 | #f | |
103 | (lambda (printer) #f) | |
104 | (lambda (printer) | |
105 | (make-pointer-iterator-except elements (value->integer len)))))) | |
106 | ||
ded03782 DE |
107 | ;; The actual pretty-printer for pp_s is split out so that we can pass |
108 | ;; in a prefix to distinguish objfile/progspace/global. | |
109 | ||
110 | (define (pp_s-printer prefix val) | |
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 "~aa=<~A> b=<~A>" prefix a b))) | |
117 | ||
ed3ef339 DE |
118 | (define (make-pp_s-printer val) |
119 | (make-pretty-printer-worker | |
120 | #f | |
121 | (lambda (printer) | |
ded03782 | 122 | (pp_s-printer "" val)) |
ed3ef339 DE |
123 | #f)) |
124 | ||
125 | (define (make-pp_ss-printer val) | |
126 | (make-pretty-printer-worker | |
127 | #f | |
128 | (lambda (printer) | |
129 | (let ((a (value-field val "a")) | |
130 | (b (value-field val "b"))) | |
131 | (format #f "a=<~A> b=<~A>" a b))) | |
132 | #f)) | |
133 | ||
134 | (define (make-pp_sss-printer val) | |
135 | (make-pretty-printer-worker | |
136 | #f | |
137 | (lambda (printer) | |
138 | (let ((a (value-field val "a")) | |
139 | (b (value-field val "b"))) | |
140 | (format #f "a=<~A> b=<~A>" a b))) | |
141 | #f)) | |
142 | ||
143 | (define (make-pp_multiple_virtual-printer val) | |
144 | (make-pretty-printer-worker | |
145 | #f | |
146 | (lambda (printer) | |
147 | (format #f "pp value variable is: ~A" (value-field val "value"))) | |
148 | #f)) | |
149 | ||
150 | (define (make-pp_vbase1-printer val) | |
151 | (make-pretty-printer-worker | |
152 | #f | |
153 | (lambda (printer) | |
154 | (format #f "pp class name: ~A" (type-tag (value-type val)))) | |
155 | #f)) | |
156 | ||
157 | (define (make-pp_nullstr-printer val) | |
158 | (make-pretty-printer-worker | |
159 | #f | |
160 | (lambda (printer) | |
161 | (value->string (value-field val "s") | |
162 | #:encoding (arch-charset (current-arch)))) | |
163 | #f)) | |
164 | ||
165 | (define (make-pp_ns-printer val) | |
166 | (make-pretty-printer-worker | |
167 | "string" | |
168 | (lambda (printer) | |
169 | (let ((len (value-field val "length"))) | |
170 | (value->string (value-field val "null_str") | |
171 | #:encoding (arch-charset (current-arch)) | |
172 | #:length (value->integer len)))) | |
173 | #f)) | |
174 | ||
175 | (define *pp-ls-encoding* #f) | |
176 | ||
177 | (define (make-pp_ls-printer val) | |
178 | (make-pretty-printer-worker | |
179 | "string" | |
180 | (lambda (printer) | |
181 | (if *pp-ls-encoding* | |
182 | (value->lazy-string (value-field val "lazy_str") | |
183 | #:encoding *pp-ls-encoding*) | |
184 | (value->lazy-string (value-field val "lazy_str")))) | |
185 | #f)) | |
186 | ||
187 | (define (make-pp_hint_error-printer val) | |
188 | "Use an invalid value for the display hint." | |
189 | (make-pretty-printer-worker | |
190 | 42 | |
191 | (lambda (printer) "hint_error_val") | |
192 | #f)) | |
193 | ||
194 | (define (make-pp_children_as_list-printer val) | |
195 | (make-pretty-printer-worker | |
196 | #f | |
197 | (lambda (printer) "children_as_list_val") | |
198 | (lambda (printer) (make-list-iterator (list (cons "one" 1)))))) | |
199 | ||
200 | (define (make-pp_outer-printer val) | |
201 | (make-pretty-printer-worker | |
202 | #f | |
203 | (lambda (printer) | |
204 | (format #f "x = ~A" (value-field val "x"))) | |
205 | (lambda (printer) | |
206 | (make-list-iterator (list (cons "s" (value-field val "s")) | |
207 | (cons "x" (value-field val "x"))))))) | |
208 | ||
209 | (define (make-memory-error-string-printer val) | |
210 | (make-pretty-printer-worker | |
211 | "string" | |
212 | (lambda (printer) | |
213 | (scm-error 'gdb:memory-error "memory-error-printer" | |
214 | "Cannot access memory." '() '())) | |
215 | #f)) | |
216 | ||
217 | (define (make-pp_eval_type-printer val) | |
218 | (make-pretty-printer-worker | |
219 | #f | |
220 | (lambda (printer) | |
221 | (execute "bt" #:to-string #t) | |
222 | (format #f "eval=<~A>" | |
223 | (value-print | |
224 | (parse-and-eval | |
225 | "eval_func (123456789, 2, 3, 4, 5, 6, 7, 8)")))) | |
226 | #f)) | |
227 | ||
228 | (define (get-type-for-printing val) | |
229 | "Return type of val, stripping away typedefs, etc." | |
230 | (let ((type (value-type val))) | |
231 | (if (= (type-code type) TYPE_CODE_REF) | |
232 | (set! type (type-target type))) | |
233 | (type-strip-typedefs (type-unqualified type)))) | |
234 | ||
235 | (define (disable-matcher!) | |
236 | (set-pretty-printer-enabled! *pretty-printer* #f)) | |
237 | ||
238 | (define (enable-matcher!) | |
239 | (set-pretty-printer-enabled! *pretty-printer* #t)) | |
240 | ||
241 | (define (make-pretty-printer-dict) | |
242 | (let ((dict (make-hash-table))) | |
243 | (hash-set! dict "struct s" make-pp_s-printer) | |
244 | (hash-set! dict "s" make-pp_s-printer) | |
245 | (hash-set! dict "S" make-pp_s-printer) | |
246 | ||
247 | (hash-set! dict "struct ss" make-pp_ss-printer) | |
248 | (hash-set! dict "ss" make-pp_ss-printer) | |
249 | (hash-set! dict "const S &" make-pp_s-printer) | |
250 | (hash-set! dict "SSS" make-pp_sss-printer) | |
251 | ||
252 | (hash-set! dict "VirtualTest" make-pp_multiple_virtual-printer) | |
253 | (hash-set! dict "Vbase1" make-pp_vbase1-printer) | |
254 | ||
255 | (hash-set! dict "struct nullstr" make-pp_nullstr-printer) | |
256 | (hash-set! dict "nullstr" make-pp_nullstr-printer) | |
257 | ||
258 | ;; Note that we purposely omit the typedef names here. | |
259 | ;; Printer lookup is based on canonical name. | |
260 | ;; However, we do need both tagged and untagged variants, to handle | |
261 | ;; both the C and C++ cases. | |
262 | (hash-set! dict "struct string_repr" make-string-printer) | |
263 | (hash-set! dict "struct container" make-container-printer) | |
264 | (hash-set! dict "struct justchildren" make-no-string-container-printer) | |
265 | (hash-set! dict "string_repr" make-string-printer) | |
266 | (hash-set! dict "container" make-container-printer) | |
267 | (hash-set! dict "justchildren" make-no-string-container-printer) | |
268 | ||
269 | (hash-set! dict "struct ns" make-pp_ns-printer) | |
270 | (hash-set! dict "ns" make-pp_ns-printer) | |
271 | ||
272 | (hash-set! dict "struct lazystring" make-pp_ls-printer) | |
273 | (hash-set! dict "lazystring" make-pp_ls-printer) | |
274 | ||
275 | (hash-set! dict "struct outerstruct" make-pp_outer-printer) | |
276 | (hash-set! dict "outerstruct" make-pp_outer-printer) | |
277 | ||
278 | (hash-set! dict "struct hint_error" make-pp_hint_error-printer) | |
279 | (hash-set! dict "hint_error" make-pp_hint_error-printer) | |
280 | ||
281 | (hash-set! dict "struct children_as_list" | |
282 | make-pp_children_as_list-printer) | |
283 | (hash-set! dict "children_as_list" make-pp_children_as_list-printer) | |
284 | ||
285 | (hash-set! dict "memory_error" make-memory-error-string-printer) | |
286 | ||
287 | (hash-set! dict "eval_type_s" make-pp_eval_type-printer) | |
288 | ||
289 | dict)) | |
290 | ||
291 | ;; This is one way to register a printer that is composed of several | |
292 | ;; subprinters, but there's no way to disable or list individual subprinters. | |
293 | ||
ded03782 DE |
294 | (define (make-pretty-printer-from-dict name dict lookup-maker) |
295 | (make-pretty-printer | |
296 | name | |
297 | (lambda (matcher val) | |
298 | (let ((printer-maker (lookup-maker dict val))) | |
299 | (and printer-maker (printer-maker val)))))) | |
300 | ||
301 | (define (lookup-pretty-printer-maker-from-dict dict val) | |
302 | (let ((type-name (type-tag (get-type-for-printing val)))) | |
303 | (and type-name | |
304 | (hash-ref dict type-name)))) | |
305 | ||
ed3ef339 | 306 | (define *pretty-printer* |
ded03782 DE |
307 | (make-pretty-printer-from-dict "pretty-printer-test" |
308 | (make-pretty-printer-dict) | |
309 | lookup-pretty-printer-maker-from-dict)) | |
ed3ef339 DE |
310 | |
311 | (append-pretty-printer! #f *pretty-printer*) | |
ded03782 DE |
312 | |
313 | ;; Different versions of a simple pretty-printer for use in testing | |
314 | ;; objfile/progspace lookup. | |
315 | ||
316 | (define (make-objfile-pp_s-printer val) | |
317 | (make-pretty-printer-worker | |
318 | #f | |
319 | (lambda (printer) | |
320 | (pp_s-printer "objfile " val)) | |
321 | #f)) | |
322 | ||
323 | (define (install-objfile-pretty-printers! pspace objfile-name) | |
324 | (let ((objfiles (filter (lambda (objfile) | |
325 | (string-contains (objfile-filename objfile) | |
326 | objfile-name)) | |
327 | (progspace-objfiles pspace))) | |
328 | (dict (make-hash-table))) | |
329 | (if (not (= (length objfiles) 1)) | |
330 | (error "objfile not found or ambiguous: " objfile-name)) | |
331 | (hash-set! dict "s" make-objfile-pp_s-printer) | |
332 | (let ((pp (make-pretty-printer-from-dict | |
333 | "objfile-pretty-printer-test" | |
334 | dict lookup-pretty-printer-maker-from-dict))) | |
335 | (append-pretty-printer! (car objfiles) pp)))) | |
336 | ||
337 | (define (make-progspace-pp_s-printer val) | |
338 | (make-pretty-printer-worker | |
339 | #f | |
340 | (lambda (printer) | |
341 | (pp_s-printer "progspace " val)) | |
342 | #f)) | |
343 | ||
344 | (define (install-progspace-pretty-printers! pspace) | |
345 | (let ((dict (make-hash-table))) | |
346 | (hash-set! dict "s" make-progspace-pp_s-printer) | |
347 | (let ((pp (make-pretty-printer-from-dict | |
348 | "progspace-pretty-printer-test" | |
349 | dict lookup-pretty-printer-maker-from-dict))) | |
350 | (append-pretty-printer! pspace pp)))) |