gdb/testsuite/gdb.guile/scm-pretty-print.scm

   1 ;; Copyright (C) 2008-2014 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))))