1;; Copyright (C) 2008-2020 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 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 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 118(define (make-pp_s-printer val) 119 (make-pretty-printer-worker 120 #f 121 (lambda (printer) 122 (pp_s-printer "" val)) 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 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 306(define *pretty-printer* 307 (make-pretty-printer-from-dict "pretty-printer-test" 308 (make-pretty-printer-dict) 309 lookup-pretty-printer-maker-from-dict)) 310 311(append-pretty-printer! #f *pretty-printer*) 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)))) 351