suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 5d8bcbed69eeb7737b23a608906eb4b9e31b0d7c
This commit is contained in:
Matthew Flatt 2005-04-30 02:27:44 +00:00
parent 674cfc1923
commit 3d3e785916
1 changed files with 19 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/mzlib/pretty.ss
View File

@ -310,6 +310,10 @@
(define (register-printing-port p info)
(hash-table-put! printing-ports p info))
(define (register-printing-port-like p pport)
(hash-table-put! printing-ports p
(hash-table-get printing-ports pport)))
(define (get pport selector)
(selector (hash-table-get printing-ports pport
(lambda ()
@ -330,6 +334,9 @@
(get pport print-port-info-print-line))
(define (printing-port-esc pport)
(get pport print-port-info-esc))
(define orig-display (port-display-handler (open-output-string)))
(define orig-write (port-write-handler (open-output-string)))
(define (pretty-print-newline pport width)
(let-values ([(l col p) (port-next-location pport)])
@ -531,20 +538,20 @@
(expr-found pport ref))
(n-k)))))))
(define (write-custom recur obj pport depth display?)
(define (write-custom recur obj pport depth display? width)
(let-values ([(l c p) (port-next-location pport)])
(let ([p (relocate-output-port pport l c p)])
(port-count-lines! p)
(let ([writer (lambda (v port)
(recur (if (eq? port p) pport port)
v (dsub1 depth) #f))]
(recur port v (dsub1 depth) #f))]
[displayer (lambda (v port)
(recur (if (eq? port p) pport port)
v (dsub1 depth) #t))])
(recur port v (dsub1 depth) #t))])
(port-write-handler p writer)
(port-display-handler p displayer)
(port-print-handler p writer))
(parameterize ([pretty-printing #t])
(register-printing-port-like p pport)
(parameterize ([pretty-printing #t]
[pretty-print-columns (or width 'infinity)])
((custom-write-accessor obj) obj p (not display?))))))
;; ------------------------------------------------------------
@ -639,7 +646,7 @@
#f #f
(lambda ()
(parameterize ([pretty-print-columns 'infinity])
(write-custom wr* obj pport depth display?))))]
(write-custom wr* obj pport depth display? width))))]
[(struct? obj)
(if (and print-struct?
(not (and depth
@ -651,7 +658,7 @@
(out "#")
(wr-lst (vector->list (struct->vector obj)) #f (sub1 depth))))
(parameterize ([print-struct #f])
((if display? display write) obj pport)))]
((if display? orig-display orig-write) obj pport)))]
[(hash-table? obj)
(if (and print-hash-table?
(not (and depth
@ -663,7 +670,7 @@
(out "#hash")
(wr-lst (hash-table-map obj cons) #f depth))
(parameterize ([print-hash-table #f])
((if display? display write) obj pport))))]
((if display? orig-display orig-write) obj pport))))]
[(boolean? obj)
(out (if obj "#t" "#f"))]
[(number? obj)
@ -678,7 +685,7 @@
(eq? obj '|.|))
(out ".")]
[else
((if display? display write) obj pport)]))
((if display? orig-display orig-write) obj pport)]))
(post-print pport obj))
;; ------------------------------------------------------------
@ -702,7 +709,7 @@
(let ([col (ccol)])
(if (< to col)
(begin
(let ([col ((printing-port-print-line pport) col width)])
(let ([col ((printing-port-print-line pport) #t col width)])
(spaces (- to col))))
(spaces (max 0 (- to col))))))
@ -751,7 +758,7 @@
(out (number->string (vector-length obj))))
(pp-list (vector->repeatless-list obj) extra pp-expr #f depth)]
[(custom-write? obj)
(write-custom pp* obj pport depth display?)]
(write-custom pp* obj pport depth display? width)]
[(struct? obj) ; print-struct is on if we got here
(out "#")
(pp-list (vector->list (struct->vector obj)) extra pp-expr #f depth)]