1 ;;;; pprint.scm --- pretty-printing objects for CGEN
2 ;;;; Copyright (C) 2005, 2009 Red Hat, Inc.
3 ;;;; This file is part of CGEN.
4 ;;;; See file COPYING.CGEN for details.
6 ;;; This file defines a printing function PPRINT, and some hooks to
7 ;;; let you print certain kind of objects in a summary way, and get at
8 ;;; their full values later.
10 ;;; PPRINT is a printer for Scheme objects that prints lists or
11 ;;; vectors that contain shared structure or cycles and prints them in
12 ;;; a finite, legible way.
14 ;;; Ordinary values print in the usual way:
16 ;;; guile> (pprint '(1 #(2 3) 4))
19 ;;; Values can share structure:
21 ;;; guile> (let* ((c (list 1 2))
27 ;;; In that list, the two instances of (1 2) are actually the same object;
28 ;;; the top-level list refers to the same object twice.
30 ;;; Printing that structure with PPRINT shows the sharing:
32 ;;; guile> (let* ((c (list 1 2))
37 ;;; Here the "#0=" before the list (1 2) labels it with the number
38 ;;; zero. Then, the "#0#" as the second element of the top-level list
39 ;;; indicates that the object appears here, too, referring to it by
42 ;;; If you have several objects that appear more than once, they each
43 ;;; get a separate label:
45 ;;; guile> (let* ((a (list 1 2))
47 ;;; (c (list a b a b)))
49 ;;; (#0=(1 2) #1=(3 4) #0# #1#)
51 ;;; Cyclic values just share structure with themselves:
53 ;;; guile> (let* ((a (list 1 #f)))
59 ;;; PPRINT also consults the function ELIDE? and ELIDED-NAME to see
60 ;;; whether it should print a value in a summary form. You can
61 ;;; re-define those functions to customize PPRINT's behavior;
62 ;;; cos-pprint.scm defines them to handle COS objects and classes
65 ;;; (ELIDE? OBJ) should return true if OBJ should be elided.
66 ;;; (ELIDED-NAME OBJ) should return a (non-cyclic!) object to be used
67 ;;; as OBJ's abbreviated form.
69 ;;; PPRINT prints an elided object as a list ($ N NAME), where NAME is
70 ;;; the value returned by ELIDED-NAME to stand for the object, and N
71 ;;; is a number; each elided object gets its own number. You can refer
72 ;;; to the elided object number N as ($ N).
74 ;;; For example, if you've loaded CGEN, pprint.scm, and cos-pprint.scm
75 ;;; (you must load cos-pprint.scm *after* loading pprint.scm), you can
76 ;;; print a list containing the <insn> and <ident> classes:
78 ;;; guile> (pprint (list <insn> <ident>))
79 ;;; (($ 1 (class <insn>)) ($ 2 (class <ident>)))
80 ;;; guile> (class-name ($ 1))
82 ;;; guile> (class-name ($ 2))
85 ;;; As a special case, PPRINT never elides the object that was passed
86 ;;; to it directly. So you can look inside an elided object by doing
89 ;;; guile> (pprint ($ 2))
90 ;;; #0=#("class" <ident> () ((name #:unbound #f . 0) ...
94 ;;; A list of elided objects, larger numbers first, and the number of
95 ;;; the first element.
96 (define elide-table '())
97 (define elide-table-last -1)
99 ;;; Add OBJ to the elided object list, and return its number.
100 (define (add-elided-object obj)
101 (set! elide-table (cons obj elide-table))
102 (set! elide-table-last (+ elide-table-last 1))
105 ;;; Referencing elided objects.
107 (if (<= 0 n elide-table-last)
108 (list-ref elide-table (- elide-table-last n))
111 ;;; A default predicate for elision.
112 (define (elide? obj) #f)
114 ;;; If (elide? OBJ) is true, return some sort of abbreviated list
115 ;;; structure that might be helpful to the user in identifying the
117 ;;; A default definition.
118 (define (elided-name obj) "")
120 ;;; This is a pretty-printer that handles cyclic and shared structure.
121 (define (pprint original-obj)
123 ;; Return true if OBJ should be elided in this call to pprint.
124 ;; (We never elide the object we were passed itself.)
125 (define (elide-this-call? obj)
126 (and (not (eq? obj original-obj))
129 ;; First, traverse OBJ and build a hash table mapping objects
130 ;; referenced more than once to #t, and everything else to #f.
131 ;; (Only include entries for objects that might be interior nodes:
132 ;; pairs and vectors.)
134 ;; Guile's stupid hash tables don't resize the table; the
135 ;; chains just get longer and longer. So we need a big value here.
136 (let ((seen (make-hash-table 65521))
137 (shared (make-hash-table 4093)))
139 (if (or (pair? obj) (vector? obj))
140 (if (hashq-ref seen obj)
141 (hashq-set! shared obj #t)
143 (hashq-set! seen obj #t)
144 (cond ((elide-this-call? obj))
145 ((pair? obj) (begin (walk! (car obj))
147 ((vector? obj) (do ((i 0 (+ i 1)))
148 ((>= i (vector-length obj)))
149 (walk! (vector-ref obj i))))
150 (else (error "unhandled interior type")))))))
154 ;; A counter for shared structure labels.
155 (define fresh-shared-label
163 (print-with-label obj (hashq-ref shared obj)))
165 ;; Print an object OBJ, which SHARED maps to L.
166 ;; L is always (hashq-ref shared obj), but we have that value handy
167 ;; at times, so this entry point lets us avoid looking it up again.
168 (define (print-with-label obj label)
170 ;; If we've already visited this object, just print a
171 ;; reference to its label.
172 (map display `("#" ,label "#"))
174 ;; If it needs a label, attach one now.
175 (if (eqv? label #t) (let ((label (fresh-shared-label)))
176 (hashq-set! shared obj label)
177 (map display `("#" ,label "="))))
179 (cond ((elide-this-call? obj)
180 (write (list '$ (add-elided-object obj) (elided-name obj))))
181 ((pair? obj) (begin (display "(")
183 ((vector? obj) (begin (display "#(")
185 ((>= i (vector-length obj)))
186 (print (vector-ref obj i))
187 (if (< (+ i 1) (vector-length obj))
190 (else (write obj))))))
192 ;; Print a pair P as if it were the tail of a list; assume the
193 ;; opening paren and any previous elements have been printed.
194 (define (print-tail obj)
197 (let ((tail (cdr obj)))
200 ;; We use the dotted pair syntax if the cdr isn't a pair, but
201 ;; also if it needs to be labeled.
202 (let ((tail-label (hashq-ref shared tail)))
203 (if (or (not (pair? tail)) tail-label)
204 (begin (display " . ")
205 (print-with-label tail tail-label)
208 (print-tail tail)))))))